Developer CD Series 1996 May: Tool Chest/Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso/Tool Chest/Development Tools & Languages/Macintosh Common Lisp Related/User Contributions/Misc.sea/Misc/save-object.lisp

Text File | 1992-04-21 | 114.5 KB | 3,672 lines | [TEXT/CCL2]

;;; -*- Base: 10; Mode: LISP; Package: (DATABASE :USE LISP); Syntax: Common-Lisp -*-

;;; SAVE-OBJECT, Version 5C, Effective Date: March, 1992.
;;; NOTE: ALLEGRO 4.0 USERS: SEE IMPORTANT INFO BELOW:
;;; Copyright (C) Kerry V. Koitzsch, 1992.

#|

The views, opinions, and/or findings contained in this document are those
of the author, and should not be construed as an official position, policy,
or decision of any company or other individual, unless designated by other
documentation.

Permission is granted to any individual or institution to use, copy,
modify and distribute this document, provided the copyright and permission
notice is maintained, intact, in all copies and supporting documentation.
The author makes no representations about the suitability of the software
described herein for any purpose. It is provided "as is" without express
or implied warranty.

Suggestions, bugs, criticism and questions to [e-mail], or
[e-mail].

SAVE-OBJECT is a recursive function which writes an ASCII representation
of a LISP object to a designated file.

NOTE: SAVE-OBJECT doesnt need a special LOAD function!
You can load files created by SAVE-OBJECT with the
standard LOAD function:

To save:

(SAVE-OBJECT (list 10 20 30) "myfile.lisp")    ,

To restore the data in the saved list:

(LOAD "myfile.lisp")

Where the newly restored data ends up:

db:*db-input* == (LIST 10 20 30)

Objects which may be saved include:

--- symbols, keywords, characters, strings, and pathnames.
--- numbers, including integer, rational, complex, and floating point.
--- vectors and multi-dimensional arrays.
--- objects produced by DEFSTRUCT.
--- CLOS (PCL) instances, and CLOS(PCL) classes.
--- hash tables.
--- compiled functions, represented as (FUNCTION <function name>),
    internally.
--- generic functions, method objects, and class objects.
--- conses and lists.
--- circular conses and lists (new)
--- user defined methods may be defined for arbitrary objects, such
    as images.
--- readtables (a kludge for now)
--- CLIM objects (saved as ordinary CLOS instances)

Calling sequence for INSTANCE-DUMP-FORM:
------- -------- --- ------------------

class-slots ==> all-slotnames ==> all-slots-and-values ==>
map-instance ==> get-slot-values ==> get-ordered-slot-values ==>
instance-dump-form.

Tested on:
------ --
Machines: Sun-4, Symbolics 3670, Mac IIfx and Mac Quadra.
Versions of Symbolics Common Lisp: Genera 8.1, Genera 7.2 w/rev 4b PCL.
Versions of PCL/CLOS: AAAI PCL, Victoria Day PCL, REV 4b PCL, Lucid 4.0
CLOS.

Versions of MCL: 2.0b3

Versions of Allegro Common Lisp: 4.0, 4.1beta.

Note: ALLEGRO 4.0 users: the patch which fixes the defstruct slot-
value problem must be installed in your 4.0 image for this code to
work properly! Franz internal problem number: spr4914, patch25.fasl.
See your Franz dealer to get a copy.

Versions of Lucid (Sun) Common Lisp: 4.0.

Directions:
-----------

(0) SPECIAL DIRECTIONS FOR USERS OF MCL2.0f3:
    ADD THE FOLLOWING LINE TO THE TOP OF YOUR FILE:
    (pushnew :mcl2.0f3 *features*)

(1) Redefine the IN-PACKAGEs below to suit: they should USE CLOS or PCL,
though.

In version 5a, the attribute line should be correct to 'just load' the
file, even if the package database does not exist.
Or, try this:

(make-package 'DATABASE :nicknames '(db) :use '(common-lisp))
(in-package 'database)
(shadowing-import '(setf documentation) 'database)
(use-package 'clos)

If at any point an error occurs about conflicting symbols, select the
proceed option which prefers the symbols in the common lisp package.

(2) After defining an appropriate package, load the file,
    save-object.lisp, or its compiled version.

(3) Enter package DATABASE with (in-package 'DATABASE). You are now
ready to save objects!

(4) To save an object to a file, invoke the save-object function:

(in-package 'database)
(save-object (list 20 30 19.6) "my-simple-filename.lisp")

to reload the saved-object file:

(load "my-simple-filename.lisp")

The result of the load is stored in the global variable *db-input*,
in the DATABASE package.

Changes from Version 4A;
------------------------

--- Attribute line is fixed for Symbolics users.

--- the ability to save CLOS instances with unbound slots: fixed the
    bug where nil was installed as the slot value. (see TEST-UNBOUND-
    SLOT-SAVE function)

--- the ability to save out CONSes (vs LISTS) in the appropriate
    format: required modification to predicate CONS-P and %TYPE-OF.
    (see TEST-CONS-SAVE function)

--- predicate %CONS-P is the internal cons predicate: EXCL uses an
    internal function: the non-EXCL version uses a Common Lisp
    version. Ideally one would use (LAST X 0) as in CLtl2 pg. 416,
    but here i use (CDR (LAST X)).

--- Better flagged for future AKCL development.

--- Unsaveable slot bug, which screwed up slots and values returned,
    is now fixed in the new mechanism using INSTANCE-SLOTNAMES.

--- Beginnings of modifications fr MCL2.0f3.

========================================================================

 Defstruct functions used by SAVE-OBJECT:
 --------- --------- ---- -- -----------

   STRUCTURE-P (x) [Function] :
   Predicate, returns T if X is a structure instance.

   DEFSTRUCT-SLOT-COUNT (s) [Function] :
   Returns the number of slots in a structure instance S.

   GET-SYMBOL-DEFSTRUCT-SPEC (symbol) [Function] :
   Given a symbol, returns a standard defstruct spec if
   SYMBOL is the name of a defined defstruct class:
   NIL otherwise.

   ALLOCATE-STRUCT (type) [Function] :
   Given a symbol TYPE which is the name of a defined defstruct
   class, make a default instance of that class.

   FILL-STRUCT (struct) [Function] :

   GET-DEFSTRUCT-CONSTRUCTOR (s) [Function] :
   Given a symbol or structure instance, return the
   name of the function that can construct an instance
   of the same type as S.

   GET-DEFSTRUCT-NAME (s) [Function] :
   Given a structure instance S, return the name of
   that instances class.

   GET-DEFSTRUCT-TYPE (s) [Function] :
   Given a symbol or structure instance S, return the
   type of that structure class.

   GET-DEFSTRUCT-SLOT-SPEC (s slotname) [Function] :

   GET-DEFSTRUCT-SLOT-ACCESSOR (s slotname) [Function] :

   SET-DEFSTRUCT-SLOT-VALUE (s slotname new-value) [Function] :

   GET-DEFSTRUCT-SLOT-VALUE (s slotname) [Function]:

   GET-DEFSTRUCT-DESCRIPTION (s) [Function] :

   MAKE-DEFSTRUCT-BODY (s) [Function] :

   GET-DEFSTRUCT-SLOT-NAMES (s) [Function] :
   Given a structure instance S, return a list of the
   names of that instances slots, in no particular order.

   GET-SLOT-SPEC-NAMED (s name) [Function] :

   COPY-STRUCTURE (s &key (mode :shallow)) [Function] :
   Analogous to the COPY-INSTANCE method. Mode may be :SHALLOW or
   :DEEP : make a copy of the structure instance S.

   GET-DEFSTRUCT-SLOTS-AND-VALS (s) [Function] :

   MAKE-STRUCTURE (struct-type &rest kwd-val-pairs) [Macro] :
   Analogous to MAKE-INSTANCE.

   GET-DEFSTRUCT-VALUES (s) [Function] :
   Return the values of all the slots in structure instance S,
   in the same order that the slot names are returned from
   GET-DEFSTRUCT-SLOT-NAMES.

|#

;;; Package engineering....

#+lucid
(in-package 'DATABASE :nicknames '(DB) :use '(CLOS LISP))

#+:mcl
(eval-when (load eval compile)

(unless (find-package 'database)
(make-package 'database  :nicknames '(db) :use '(common-lisp)))

(in-package DATABASE) ;;;; ANSI definition of IN-PACKAGE

;;;; Uncomment the following line if using mcl2.0f3....
;;;(PUSHNEW :mcl2.0f3 *features*)
(pushnew :clos *features*) ;;; MCL has clos, but it isnt in the features list...

(unless (find-package 'clos)
(make-package 'clos :use '(ccl common-lisp))) ;;; hence no cl package, either.

(when (equal (machine-instance) "Quadra")
       (pushnew :quadra *features*) ;;; note that its a 68040 on features....
)

(when (equal (machine-type) "Macintosh IIfx")
       (pushnew :fx *features*) ;;; note that its an fx on features....
)
) ;;; end of MCL eval-when...
#+lispm
(eval-when (load eval compile)

(multiple-value-bind (major minor status)
  (sct:get-release-version)
(cond ((and (equal major 7)(equal minor "2"))(pushnew :rel-7-2 *features*))
      ((and (equal major 8)(member minor '("0" "1") :test #'equal))
        (pushnew :rel8 *features*)
        (if (equal minor "0")(pushnew :rel-8-0 *features*)
        (pushnew :rel-8-1 *features*)))
      (T (error "Can't deal with major release ~a, minor release ~a!" major minor))))

(when (find-package 'clos)
      (pushnew :clos *features*))

(unless (find-package 'database)
        (make-package 'database :nicknames '(db) :use '(clos)))

(shadowing-import '(setf documentation) 'database)

(unless (find-package 'clos)(format t "Couldnt find the CLOS package, trying to continue.~%"))

(in-package 'database :use '(LISP))

(defun UNLOCK-PKG (packagename)
"Changes read-only package status to read+write, if package exists."
(when (find-package packagename)
(setf (si:pkg-locked (find-package packagename)) NIL)))

) ;;; end of Symbolics eval-when. Worry about TI much later.

;;; Initial package-building eval-when for allegro on suns.

#+excl
(eval-when (load compile eval)

(setf excl:*cltl1-in-package-compatibility-p* T)

(in-package :Common-lisp-user)

(defpackage "database" (:nicknames "dbs") (:use :clos :excl :common-lisp-user))

(in-package DATABASE)

(in-package 'DATABASE)

#+allegro-v4.1
(defun UNLOCK-PKG (packagename)
"Changes read-only package status to read+write, if package exists."
(when (find-package packagename)
    (setf (excl::package-lock-fdefinitions
       (find-package packagename)) NIL)))

#+allegro-v4.1
(unlock-pkg 'common-lisp)

) ;;; end of excl eval-when...

;;; Set up correct Lucid hash-table accessors....

#+lucid
(shadowing-import '(lcl::hash-table-rehash-size
            lcl::hash-table-size
            lcl::hash-table-test
            lcl::hash-table-rehash-threshold
) 'database)

#+lucid
(eval-when (load eval compile)
(setf (symbol-function 'hash-table-rehash-size) #'lcl::hash-table-rehash-size)
(setf (symbol-function 'hash-table-size) #'lcl::hash-table-size)
(setf (symbol-function 'hash-table-test) #'lcl::hash-table-test)
(setf (symbol-function 'hash-table-rehash-threshold)
      #'lcl::hash-table-rehash-threshold))

;;; NOTE: Change the package def below if it does not suit you:
;;; make sure you USE-PACKAGE your favorite brand of CLOS or PCL, though.

#+lispm
(in-package 'DATABASE :nicknames '(DB) :use '(CLOS LISP))

#+pcl
(in-package 'DATABASE :nicknames '(DB) :use '(PCL LISP))

;;; exported symbols....

;;; Exports.

(export '(stream-fasd-form
       symbol-fasd-form
       readtable-fasd-form
       generic-function-fasd-form
       method-fasd-form
       class-fasd-form
       complex-fasd-form
       array-fasd-form
       structure-fasd-form
       vector-fasd-form
       compiled-function-fasd-form
       instance-fasd-form
       htab-fasd-form
       cons-fasd-form))

(export '(*db-input*
      *global-unsavable-slots*
      save-object
      pseudo-quote-reader
      reset-symbol-counter
      hash-table-size
      hash-table-rehash-size
      hash-table-rehash-threshold
      hash-table-test
      make-keyword
      string-append
      all-slots
      all-slotnames
      copy-instance
      all-slots-and-values
      all-values
      %allocate-instance
      find-generic-function
      methodp
      instance-p
      instance-name
      structure-p
      get-slot-values
      pushsym
      list-array
      coerce-2d-array
      make-defstruct-body

      %make-array

      describe-htab
      cons-p

      array-list-aux
      set-defstruct-slot
      get-defstruct-value

      makesyms
      write-global-header))

(export '(*global-unsaveable-slotnames*
      *save-object-system-date*)
)

(export '(structure-p
      defstruct-slot-count
      get-symbol-defstruct-spec
      allocate-struct
      fill-struct
      get-defstruct-constructor
      get-defstruct-name
      get-defstruct-type
      get-defstruct-slot-spec
      get-defstruct-slot-accessor
      set-defstruct-slot-value
          get-defstruct-slot-value
      get-defstruct-slot-names
      get-defstruct-values
      make-structure
      get-defstruct-slots-and-vals
      copy-structure
      get-slot-spec-named
      get-defstruct-description
      make-defstruct-body))

(export '(admissible-constant-p
      list-of-constants-p))

(export '(quoted-symbol-dump-form
      simple-list-dump-form))

(export '(get-unsaveable-slotnames
          unsaveable-slot-p
      instance-slotnames
      instance-slotnames-minus-unsaveables
          instance-values
      instance-values-minus-unsavables))

#-excl
(in-package 'DATABASE)

#|

(shadow '(defun))

(defmacro DEFUN (name &rest args)
`(eval-when (eval load compile)
        (format t "now compiling: ~a.~%" ',name)
        (lisp:defun ,name ,@args)))
|#

;;;;; Globals.

(defvar *debug-instance-storage* nil "when this one is T, status messages are printed by the CLOS instance saver to aid diagnosis of problems.")

(defvar *debug-local-bindings* nil "set this var to t to see a printout of the constructed lexical bindings as they are created.")

(defvar *supress-standard-object* T "")
(defvar *save-contents-of-class-allocated-classes* NIL "")

(defvar *make-list-length-threshold* 10
"any list longer than this, which has the same element throughout,
is constructed with MAKE-LIST instead of (list el el el el el el....)."
)
(defvar *load-object-hash-table* (make-hash-table :size 50 :test #'eql)
"A hash table which is filled at load time with objects restored from a
file.")

(defvar *save-object-hash-table* (make-hash-table :size 50 :test #'eql)
"A hash table which is filled at save time by the invokation of the
save object function.")

(defvar *mode-for-set-object-var* nil "Either :load or :save, depending
on the context. Used by SET-OBJECT-VAR.")

(defvar *mode-for-object-var* :save)

(defvar *global-unsaveable-slotnames* nil "")

(defvar *save-object-system-date*
"March 1992 Save Object 5 B Experimental.")

(defvar *unbound-slot-token* '%%.us.%)
(defvar *debug-htab-load* t)
(defvar *debug-struct-save* nil)

(defvar *seen* nil)
(defvar *vars* nil)
(defvar *structs-seen* nil)
(defvar *struct-vars* nil)
(defvar *htabs-seen* nil)
(defvar *htab-vars* nil)

(defvar *arrays-seen* nil)
(defvar *array-vars* nil)
(defvar *vectors-seen* nil)
(defvar *vector-vars* nil)

(defvar *current-htab-size* 5000)
(defvar *current-htab-rehash-threshold* 65)
(defvar *current-htab-rehash-size* 39)
(defvar *current-htab-test* #'eql)

(defvar *pco-types* '(structure hash-table array-type-t
              class instance circular-list)
"A list of the type names returned by function %type-of, that
are potentially circular objects (PCOs).")

(setf *pco-types* '(structure hash-table array-type-t
              class instance circular-list))

#+lucid
(setf lcl::*print-structure* T) ;;;; "Prints the #S form of a defstruct when t."

(defvar *global-instance-count* 0)

(defvar *global-object-count* 0
 "count of varnames made for object hashtable objects, by makevar in cache-object invokations.")

(defvar *use-default-class-initargs* nil)
(defvar *unsaveable-slot-token* '%.uns.%)

;;; --------------------------- AKCL DEFSTRUCT -----------------------------

#+akcl
(eval-when (load eval compile)

(defun STRUCTURE-P (X)
"Predicate: returns T if x is a structure instance!"
)
) ;;; end of akcl defstruct eval-when...

;;; --------------------------- SYMBOLICS DEFSTRUCT ------------------------

#+symbolics
(eval-when (load eval compile)

(defun GET-SYMBOLS-DEFSTRUCT-SPEC (x)
"for the slimebolical , this information is kept as a property."
(si:get x 'si:defstruct-description))

(defun %STRUCTURE-P (x)
"predicate, if symbol returns t if it names a struct."
(cond ((and (symbolp x)(get-symbols-defstruct-spec x)) T)
      ((structure-p x) T)
      (T NIL)))

(defun FILL-STRUCT (struct vals)
(loop for slotname in (get-defstruct-slotnames struct) do
  (set-defstruct-value struct slotname (pop vals)))
 struct)

(defun ALL-SLOTS (instance)
"Gets all the slots from the instances class, whether inherited or not."
(clos::class-slots (clos::class-of instance)))

(defun %CLASS-NAME (x)
""
(if (instance-p x)(clos::class-name (clos::class-of x))
(clos::class-name x)))

(defun GET-SUPERCLASS-NAMES (class)
""
(mapcar #'clos::class-name (clos::class-direct-superclasses class)))

(defun GET-DEFSTRUCT-CONSTRUCTOR (defstruct-name)
"Derived from defstruct sources genera 8.1: file:sys:sys2;struct.lisp."
(si:get-defstruct-constructor-macro-name defstruct-name))

(defun GET-DEFSTRUCT-NAME (struct-instance)
""
(if (typep struct-instance 'list)
 (progn  (warn "~a has a type which is not parsable == ~a.~%"
  struct-instance (type-of struct-instance)) nil)
 (nth 10 (si:get-defstruct-description (type-of struct-instance)))))

(defun GET-DEFSTRUCT-NAME (struct-instance)
""
(type-of struct-instance))

(defun GET-DEFSTRUCT-SLOT (struct-instance slotname)
(let ((structure-name (get-defstruct-name struct-instance)))
         (cdr (si:assq slotname (si:defstruct-description-slot-alist
    (si:get-defstruct-description structure-name))))))

#+rel-7-2
(defun SET-DEFSTRUCT-VALUE (struct-instance slotname value)
(let ((slot (get-defstruct-slot struct-instance slotname)))
(EVAL `(setf (,(first (reverse slot)) ,struct-instance) ,value))))

#+rel8
(defun SET-DEFSTRUCT-VALUE (object slotname newval)
"SETF (SLOT-VALUE <structure instance> '<slotname>) newval apparently
works properly."
(setf (slot-value object (make-sym slotname)) newval))

(defun STRUCTURE-P (X)
"Predicate for structure instances --- Symbolics..."
(cli::structurep x))

(setf (symbol-function 'structurep) #'structure-p)

(defun STRUCTURE-INSTANCE-P (X)
"Predicate which returns t if the object is a STRUCTURE, NOT AN INSTANCE THEREOF!"
(and (structurep x)(not (instance-p x))))

(defun MAKE-DEFSTRUCT-BODY (slot-names slot-values)
  "makes a list of keyword value pairs appropriate for the body of a MAKE-x
   defstruct invokation. note the recursive call to dump-form, which is where
   all the real work happens."
  (loop while (and slot-names slot-values) nconc
    (list (make-keyword (pop slot-names))
          (get-dump-form (pop slot-values)))
              into answers finally (return answers)))

(defun GET-DEFSTRUCT-DESCRIPTION (x)
(if (not (structurep x))
    (progn (format t "~A is not a structure! you lose...." x)
    NIL)
(si:get (or (AND (ARRAYP X) (si:NAMED-STRUCTURE-SYMBOL X))
               (AND (LISTP X) (SYMBOLP (CAR X)) (CAR X)))
                   'si:DEFSTRUCT-DESCRIPTION)))

(defun QUOTEMEMBERS (lst)
(loop for cell in lst collect `(QUOTE ,cell)))

(defun CSV ()
"clear struct vars."
(setf *struct-vars* nil *structs-seen* nil))

;;; some things about this one are still bogus....

(defun GET-DEFSTRUCT-SLOTNAMES (x)
""
(mapcar #'first (fourth (get-defstruct-description x))))

(defun GET-DEFSTRUCT-SLOTS-AND-VALS (x)
  "given a defstruct instance, return a list of the slots and vals in that defstruct."
  (let* ((desc (get-defstruct-description x))
     (slot-names (get-defstruct-slotnames x))
     (accessor-functions (mapcar #'(lambda (slot)
                     (first (reverse slot)))
                     (fourth desc)))
     (slot-values (loop for acc in accessor-functions collect
                (funcall acc x))))
(get-dump-form (mapcar #'(lambda (e1 e2)(list e1 e2))
         slot-names slot-values))))

(defun FORMATTED-DEFSTRUCT-SLOTS-AND-VALS (x)
  (let ((initial (get-defstruct-slots-and-vals x)))
    (loop for thang in initial nconc (list (make-keyword (first thang))
                       (get-dump-form (rest thang))))))

(defun GET-DEFSTRUCT-SLOTS (x)
  "given a defstruct instance, return a list of the slots in that defstruct (no values)."
  (let* ((desc (get-defstruct-description x))
     (slot-names (mapcar #'first (fourth desc))))
         slot-names))

(defun STRUCTURE-SLOTD-NAME (slotd)
  (first slotd))

(defun STRUCTURE-SLOTD-READER (slotd)
  (second slotd))

(defun STRUCTURE-SLOTD-WRITER (slotd)
  (third slotd))

(defun GET-DEFSTRUCT-SLOT-ACCESSOR (instance slotname)
""
(or (first (LAST (assoc slotname (fourth (get-defstruct-description instance)))))
    (read-from-string (concatenate 'string (format nil "~A" (type-of instance))
                   "-" (format nil "~A" slotname)))))

(defun GET-DEFSTRUCT-VALUE (instance slotname)
"Given an instance of a defstruct, and the name of some slot, return the slots value."
(apply (get-defstruct-slot-accessor instance slotname)(list instance)))

(defun GET-DEFSTRUCT-VALUES (instance)
""
(loop for slot in (get-defstruct-slots instance) collect
(get-defstruct-value instance slot)))

(defun GET-DEFSTRUCT-TYPE (struct)
  (type-of struct))

(defsetf get-defstruct-value set-defstruct-value)

(setf (symbol-function 'get-struct-slotnames-from-struct)
      #'get-defstruct-slotnames)

) ;;; end of symbolics defstruct eval-when...

;;; --------------------------- MCL DEFSTRUCT ------------------------------

#+:mcl
(eval-when (load eval compile)

(defun GET-SYMBOLS-DEFSTRUCT-SPEC (symbol)
"If the symbol names a defstruct, it returns that defstructs spec."
(declare (ignore symbol))
nil)

(defun FILL-STRUCT (struct vals)
"Fills up the structure instance: invoked by STRUCTURE-FASD_FORM, GET-DUMP-FORM"
(loop for slotname in (get-defstruct-slots struct) do
  (set-defstruct-value struct slotname (pop vals)))
 struct)

(defun GET-DEFSTRUCT-NAME (instance)
""
(type-of instance))

  (defun GET-DEFSTRUCT-TYPE (instance)
""
    (car (ccl::struct-ref instance 0)))

  (defun SET-DEFSTRUCT-VALUE (instance slotname value)
""
(when (null instance)(error "set-defstruct-value got NULL instead of an instance!"))
    (let* ((struct-slot-value-list (inspector::structure-slots instance))
           (slotname-position (1+ (position slotname
                                            struct-slot-value-list
                                            :key #'first))))
(when (null slotname-position)(error "couldnt find slotname ~a in ~a!" slotname instance))
      (ccl::struct-set instance slotname-position value)))

(defun GET-DEFSTRUCT-VALUES (instance)
"Return a supposedly ordered list of the defstruct instances values."
(get-odds (get-defstruct-slots-and-vals instance)))

  (defun GET-DEFSTRUCT-VALUE (instance slotname)
    "Given an instance of a defstruct, and the name of some slot, return the slots value."
    (let* ((struct-slot-value-list (inspector::structure-slots instance))
           (slotname-position (1+ (position slotname
                                            struct-slot-value-list
                                            :key #'first))))
      (ccl::struct-ref instance slotname-position)))

  (defsetf get-defstruct-value set-defstruct-value)

(defun GET-DEFSTRUCT-SLOT-ACCESSOR (instance slotname)
    ""
    (let* ((id (GET-DEFSTRUCT-TYPE instance)))
      (read-from-string (concatenate 'string (symbol-name id) "-"
                     (symbol-name slotname)))))

(defun GET-DEFSTRUCT-SLOTS-AND-VALS (instance)
  "Return a list of slots and values" ;Note that slots are not keyword names
  (labels ((interlock-lists (list1 list2 &optional interlocked-list)
                            (if (and list1 list2)
                              (cons (car list1)
                                    (cons (car list2)
                                          (interlock-lists (rest list1)
                                                           (rest list2)
                                                           interlocked-list)))
                              interlocked-list)))
    (let* ((struct-slot-value-list (inspector::structure-slots instance))
           (slot-list (mapcar #'first struct-slot-value-list))
           (vals-list '()))
      (dotimes (i (length slot-list))
        (push (ccl::struct-ref instance (1+ i)) vals-list))
      (setf vals-list (nreverse vals-list))
      (interlock-lists slot-list vals-list))))

(defun GET-DEFSTRUCT-SLOTS (instance)
  "Return a list of slots" ;Note that slots are not keyword names
  (let* ((struct-slot-value-list (inspector::structure-slots instance)))
    (mapcar #'first struct-slot-value-list)))

(setf (symbol-function 'get-struct-slotnames-from-struct) #'get-defstruct-slots)

(defun BUILTIN-CLASS-p (X)
"Predicate to determine whether a class object is a built-in class: this should be the generic definition of this one."
(typep x 'built-in-class))

) ;;; end of MCl defstruct eval-when...

;;; --------------------------- LUCID DEFSTRUCT ----------------------------

#+lucid
(eval-when (load eval compile)

(defun COMPILED-FUNCTION-DUMP-FORM (X)
"dump form for hashmark-quote e.g. (FUNCTION name) forms."
  `(function ,(get-compiled-function-name x)))

(defun FUNCTION-NAME (x)
"The 1th slot of the procedure struct is the function name in Lucid 4.0.
 i.e. SYS:PROCEDURE-SYMBOL <X>. SYS:PROCEDURE-SYMBOL is a constant, representing the
index to the function name within the procedures slots. (see wizard doc for 4.0 lucid."
(when (sys:procedurep x)(sys:procedure-ref x SYS:PROCEDURE-SYMBOL)))

(defun GET-COMPILED-FUNCTION-NAME (compiled-function)
""
(function-name compiled-function))

;;; Long-list functions for Lucid.

(defun LONG-LIST-DUMP-FORM (instance)
`(nconc ,@(make-list-forms (partition-long-list instance))))

(defun MAKE-LIST-FORMS (lists)
  (loop for list in lists collect (get-dump-form list)))

(defun PARTITION-LONG-LIST (long-list &optional (limit 512))
"Some LISPs have a limit on the number of list components: this function partitions a
 list longer than the supplied limit appropriately for saving to file."
(loop while long-list collect
      (loop for count from 0 to (- limit 2) while long-list
        collect (pop long-list))))

(defun GET-DEFSTRUCT-CONSTRUCTOR (name)
"Extracts the name of the constructor function from the instance name."
(third (multiple-value-list (system::defstruct-info name))))

(defun STRUCTURE-P (x)
"Predicate to determine if something is a structure instance:
 NOTE: there is overlap of types in Lucid, in this case hash tables."
  (and (typep x 'structure)
       (NOT (VECTORP X))
       (not (hash-table-p x))
       (not (typep x 'simple-vector))
       (not (typep x 'simple-array))
        (not (and (arrayp x)(> (array-rank x) 1)))))

#+pcl
(defun STRUCTURE-TYPE-P (type)
  (let ((s-data (gethash type lucid::*defstructs*)))
 (or (and s-data (eq 'structure (system::structure-ref s-data 1 'defstruct)))
    (eq pcl::*structure-type* type))))

(defun STRUCTURE-SLOTD-NAME (slotd)
  (first slotd))

(defun STRUCTURE-SLOTD-READER (slotd)
  (second slotd))

(defun STRUCTURE-SLOTD-WRITER (slotd)
  (third slotd))

(defun SET-DEFSTRUCT-VALUE (instance slotname value)
(EVAL `(setf (,(get-defstruct-slot-accessor instance slotname) ,instance)
         ',value)))

(defun GET-DEFSTRUCT-VALUE (instance slotname)
"Given an instance of a defstruct, and the name of some slot, return the slots value."
(apply (get-defstruct-slot-accessor instance slotname)(list instance)))

(defsetf get-defstruct-value set-defstruct-value)

(defun GET-DEFSTRUCT-SLOT-LOCATION (i name)
(position name (nreverse (get-defstruct-slotnames i))))

(defun GET-DEFSTRUCT-SLOT-ACCESSOR (instance slotname)
""
(let* ((id (type-of instance))
       (answer nil))
  (multiple-value-bind (a accessor b c d)
  (system:defstruct-slot-info id
      (get-defstruct-slot-location instance slotname))
  a b c d
 (setf answer accessor)
answer)))

(defun FILL-STRUCT (struct vals)
(loop for slotname in (get-defstruct-slotnames struct) do
  (set-defstruct-value struct slotname (pop vals)))
 struct)

(defun GET-DEFSTRUCT-SLOTS-AND-VALS (i)
(loop for name in (get-defstruct-slotnames i) collect
           (cons name (get-defstruct-value i name))))

(defun GET-DEFSTRUCT-VALUES (s)
""
(loop for name in (get-defstruct-slotnames s) collect
 (get-defstruct-value s name)))

(defun GET-DEFSTRUCT-SLOTNAMES (i)
  (let ((id (type-of i)))
  (multiple-value-bind (indices a b c)
   (system:defstruct-info ID)
      (declare (ignore a b c))
      (let ((answers nil))
    (dotimes (count indices answers)
      (multiple-value-bind (name d value e f)
          (system:defstruct-slot-info ID count)
          (declare (ignore value d e f))
          (push name answers)
          answers))))))

(setf (symbol-function 'get-struct-slotnames-from-struct) #'get-defstruct-slotnames)

(defun %STRUCTURE-P (symbol)
""
(system:defstruct-info symbol))

(defun %CLASS-NAME (class-object)
""
(clos::class-name class-object))

(defun GET-DEFSTRUCT-TYPE (x)
(type-of x))

(defun GET-DEFSTRUCT-NAME (x)
(type-of x))

) ;;; end of lucid defstruct eval-when...

;;; --------------------------- ALLEGRO DEFSTRUCT --------------------------

#+excl
(eval-when (load eval compile)

(defun GET-DEFSTRUCT-CONSTRUCTOR (instance)
""
(if (symbolp instance)
(debug::struct-constructor instance)))

(defun  GET-SLOT-NAMED (instance name)
""
(dolist (x (%get-defstruct-slots instance))
  (when (equal name (slot-value x 'excl::name))
        (return-from get-slot-named x))))

(defun GET-DEFSTRUCT-SLOT-ACCESSOR (instance slotname)
""
(when (null instance)(error "~a was not a structure instance!" instance))
(slot-value (get-slot-named instance slotname) 'excl::accessor))

(defun SET-DEFSTRUCT-VALUE (struct slotname value)
(setf (slot-value struct slotname) value))

#+allegro-v4.1
(defun %STRUCTURE-P (x)
"Predicate returns T if X is an instance of the STRUCTURE-CLASS (CLOS)"
(cond ((and (symbolp x)(find-class x nil)
        (equal (class-name (find-class x)) 'clos::structure-class)) T)
      ((equal (instance-name  (find-class (type-of x) nil))
          'clos::structure-class) T)
      (T NIL)))

#+allegro-v4.0
(defun %STRUCTURE-P (x)
"Predicate returns T if X is an instance of the STRUCTURE-CLASS (CLOS)"
(cond ((and (symbolp x)(find-class x nil)
        (equal (class-name (find-class x)) 'clos::structure-object)) T)
      ((equal (instance-name  (find-class (type-of x) nil))
          'clos::structure-object) T)
      (T NIL)))

(defun GET-DEFSTRUCT-TYPE (s)
"given defstruct instance s, return type of s."
(excl::structure-ref s 0))

(defun GET-DEFSTRUCT-DESCRIPTION (defstruct-name)
"Given name, return description object."
(nassoc 'excl::%structure-definition (symbol-plist defstruct-name)))

(defun GET-DEFSTRUCT-SLOTS (description)
"Given defstruct description, return slot objects."
(excl::structure-ref description 3))

(defun GET-DEFSTRUCT-NAME (s)
"Given structure instance S, return the name of defstruct class."
(slot-value s 'excl::name))

(defun %GET-DEFSTRUCT-SLOTS (instance)
""
(get-defstruct-slots
 (get-defstruct-description
  (get-defstruct-type instance))))

(defuN GET-STRUCT-SLOTNAMES-FROM-STRUCT (struct)
(get-defstruct-slotnames (get-defstruct-slots
 (get-defstruct-description (get-defstruct-type struct)))))

(defun GET-DEFSTRUCT-SLOTNAMES (slot-list)
"Given list of slot objects, return slotnames as keywords."
(mapcar #'make-keyword (mapcar #'(lambda (x)(excl::structure-ref x 1))
                   slot-list)))

(defun %GET-DEFSTRUCT-SLOTNAMES (slot-list)
"Given list of slot objects, return slotnames as symbols."
(if (listp slot-list)
 (mapcar #'(lambda (x)(excl::structure-ref x 1)) slot-list)
(let ((the-ones    (get-defstruct-slots (get-defstruct-description
                       (get-defstruct-type slot-list)))))
(mapcar #'get-defstruct-name
    (if (listp the-ones) the-ones (list the-ones))))))

(defun DEFSTRUCT-SLOT-COUNT (instance)
""
(length (delete nil (get-defstruct-slotnames
              (get-defstruct-slots
            (get-defstruct-description
              (get-defstruct-type instance)))))))

(defun %%GET-DEFSTRUCT-SLOTNAMES (instance)
(get-struct-slotnames-from-struct instance))

(defun GET-DEFSTRUCT-VALUES (instance)
(let* ((slotnames (%%get-defstruct-slotnames instance))
       (length (length slotnames))
       (answers nil))
    (dolist (slot slotnames (nreverse answers))
   (push (get-defstruct-value instance slot) answers))
(nreverse answers)))

(defun GET-DEFSTRUCT-SLOTS-AND-VALS (instance)
""
(let* ((type (get-defstruct-type instance))
       (desc (get-defstruct-description type))
       (slots (get-defstruct-slots desc))
       (slotnames (DELETE NIL (get-defstruct-slotnames slots)))
       (len (length slotnames))
       (answers nil)
       (values (get-defstruct-values instance)))
(dotimes (count (1- len) answers)
(setf answers (append answers (list (nth count slotnames)
(get-dump-form (nth count values))))))))

(defun GET-DEFSTRUCT-VALUE (instance slotname)
(slot-value instance (make-sym slotname)))

(defun STRUCTUREP (x)
"Predicate to test whether some object is a structure instance."
(excl::structurep x))

(defun STRUCTURE-P (X)
"Predicate: returns T if x is a structure instance!"
(structurep x))

) ;;; end of allegro defstruct eval-when...

;;; Predicates.
;;; Lists of 'admissible constants': non-structured constants.

(defun ADMISSIBLE-CONSTANT-P (X)
"Predicate: returns T if x is symbol, number, or keyword."
(or (stringp x)
    (null x)
    (equal x T)
    (pathnamep x)
    (numberp x)
    (keywordp x)
    (characterp x)))

(defun SIMPLE-LIST-P (X)
"Predicate: returns t if every element of a list X is an
admissible constant."
(and (not (cons-p x))
     (listp x)
     (not (circular-list-p X))
     (every #'admissible-constant-p x)))

(defun LIST-TYPE (X)
  (cond ((not (listp x))
     (format t "error: ~a is not a list~%" x))
    ((cons-p x) 'cons)
    ((simple-list-p x) 'simple)
    ((quoted-list-p x) 'quoted)
    (T 'ordinary)))

;;; Vendor-independent defstruct functions.

(defun MAPSTRUCT (fun struct &key concat modify)
"Iterator for defstruct instances."
(let ((answers nil))
(dolist (slotname (get-struct-slotnames-from-struct struct) struct)
(when concat (push (funcall fun slotname (get-defstruct-value struct slotname))
           answers))
(when modify  (set-defstruct-value struct slotname
      (funcall fun slotname
      (get-defstruct-value struct slotname)))))
(if modify struct (nreverse answers))))

(defmacro MAKE-STRUCTURE (name &rest kwd-val-pairs)
"Macro analogous to make-instance, but for bona fide structures."
`(funcall (get-defstruct-constructor ,name) ,@kwd-val-pairs))

(defun %FILL-STRUCT (struct &rest vals)
"vals was quoted....and was comma atsign before, now just comma"
(EVAL `(fill-struct ,struct ',@vals)))

(defun MAKE-DEFSTRUCT-VALUES (struct)
"WAS CDR of the GET-DUMP-FORM before."
`(,@(get-defstruct-values struct)))

#-(or excl lucid)
(defun STRUCTURE-DUMP-FORM (instance)
"Independent of vendor: make-defstruct-values was UNquoted."
`(fill-struct ,(get-instance-label instance)
           (LIST ,@(get-defstruct-values instance))))

#+allegro-v4.0
(defun STRUCTURE-DUMP-FORM (instance)
"Independent of vendor: make-defstruct-values was UNquoted."
`(fill-struct ,(get-instance-label instance)
           (LIST ,@(get-defstruct-values instance))))

#+(or lucid allegro-v4.1)
(defun STRUCTURE-DUMP-FORM (instance)
"in version 4.1 allegro, treat structure instances just like clos instances!"
 `(fill-instance ,(get-instance-label instance)
         (LIST ,@(get-ordered-slot-values instance))))

#-excl
(defun FILL-STRUCT (struct vals)
"Fills the structure instance struct with the values vals."
(dolist (slotname (get-defstruct-slotnames struct) struct)
  (set-defstruct-value struct slotname (pop vals)))
 struct)

#+excl
(defun FILL-STRUCT (struct vals)
"Fills the structure instance struct with the values vals."
(dolist (slotname (%get-defstruct-slotnames struct) struct)
  (set-defstruct-value struct slotname (pop vals)))
 struct)

(defun ALLOCATE-STRUCT (name)
"Function to allocate the empty husk of a defstruct."
(apply (get-defstruct-constructor name) nil))

;;; Dump forms.

(defun CONSTANT-DUMP-FORM (instance)
"Anything which evals to itself (aside from structured objects),
 can be written as is."
instance)

(defun COMPLEX-DUMP-FORM (instance)
"Dumps anything which is a complex number."
`(COMPLEX ,(get-dump-form (REALPART instance))
      ,(get-dump-form (IMAGPART instance))))

(defun QUOTED-SYMBOL-DUMP-FORM (instance)
"Dump form for a quoted symbol."
`(QUOTE ,(second instance)))

(defun SIMPLE-LEX-LIST-P (X)
(and (not (cons-p x))
     (listp x)
     (not (circular-list-p x))
     (every #'(lambda (e)
             (or (special-marker-p e)
                 (admissible-constant-p e)))
             x)))

(defun SIMPLE-LIST-DUMP-FORM (instance)
"Dump form for lists of admissible cnstants."
`(LIST ,@instance))

(defun DEFSTRUCT-DUMP-FORM (instance)
"Vendor independent!"
`(fill-struct ,(get-instance-label instance)
          ',(get-defstruct-values instance)))

(defun REGULAR-FUNCTION-DUMP-FORM (instance)
""
`(FUNCTION ,instance))

;;; Lucid is the only one that has a list length limit.

#-lucid
(eval-when (load eval compile)

(defun LONG-LIST-DUMP-FORM (instance)
""
(list-dump-form instance))

) ;;; long-list eval-when.

(defun LIST-DUMP-FORM (instance)
""
`(LIST ,@(mapcar #'(lambda (thing)
             (get-dump-form thing))
         instance)))

;;; Vendor independent, PCL/CLOS independent CLOS functions.

(defun PAIR-SLOTNAMES (instance)
"Makes an alist of the slotnames with their 'stripped' values."
(let ((slots (all-slotnames instance)))
  (pairlis (mapcar #'strip-package slots) slots)))

(defun FIND-PACKAGED-SLOTNAME (instance stripped)
  "Given the slotname WITHOUT package, find the slotname WITH package."
(let ((choices (pair-slotnames instance)))
  (rest (assoc stripped choices :test #'equal))))

(defun SLOT-VALUE-ANY (instance stripped)
"Find the value of the real slot given the stripped name."
(let ((slotname (find-packaged-slotname instance stripped)))
  (when slotname (if (slot-boundp instance slotname)
             (slot-value instance slotname)
             *unbound-slot-token*))))

(defun GET-UNSAVEABLE-SLOTNAMES (instance)
"Returns a list of the slotnames in instance, or the slotnames
 in the class of instance, which have been marked as unsaveable,
 appended to the list of *global-unsaveable-slotnames*"
(append (copy-list *global-unsaveable-slotnames*)
    (slot-value-any instance 'unsaveable)))

(defun UNSAVEABLE-SLOT-P (slot instance)
"Predicate returns t if the slotname SLOT is marked as USAVEABLE
for instances of the type of instance."
(or (member slot *global-unsaveable-slotnames* :test #'equal)
    (member slot (get-unsaveable-slotnames instance) :test #'equal)))

;;; ROW MAJOR AREF --- ACL doesnt have it, Genera has it in package FCL....

;;; lucid has row-major-aref, no problem.

#+(or rel-8-0 rel-8-1)
(shadowing-import '(future-common-lisp:row-major-aref) 'database)

#-(or lispm rel-8-0 rel-8-1 lucid)
(when (not (fboundp 'row-major-aref))
(pushnew :need-row-major-aref *features*))

;;; lispm has it.

#-lispm
(eval-when (load eval compile)

#+need-row-major-aref
(defun ROW-MAJOR-AREF (array index)
"We have to define this, as Franz does not implement RMA pg. 450 CLtL2.
 NOTE: Neither does Symbolics."
(aref (make-array (array-total-size array)
          :displaced-to array
          :element-type (array-element-type array))
      index))

#+need-row-major-aref
(defun ROW-MAJOR-SETA (array index newval)
"so we can defsetf row-major-aref!"
(setf (aref (make-array (array-total-size array)
            :displaced-to array
            :element-type (array-element-type array))
        index) newval))

#+need-row-major-aref
(defsetf row-major-aref row-major-seta)

) ;;; eval-when....

#+ignore
(defun GET-INSTANCE-LABEL (instance)
""
(let* ((lists (case (%type-of instance)
                (INSTANCE (list *seen* *vars*))
                (STRUCTURE (list *structs-seen* *struct-vars*))
                (HASH-TABLE (list *htabs-seen* *htab-vars*))
                (otherwise (error "Couldnt parse ~a, of type ~a!"
                                  instance (type-of instance))))))
  (let* ((instance-list (first lists))
         (var-list (second lists))
         (where (position instance instance-list :test #'equal)))
    (when (null where)(error "~a was not on the seen list!" instance))
(nth where var-list))))

(defun GET-INSTANCE-LABEL (instance)
""
(let* ((lists (case (%type-of instance)
                (INSTANCE (list *seen* *vars*))
                (STRUCTURE (list *structs-seen* *struct-vars*))
                (HASH-TABLE (list *htabs-seen* *htab-vars*))
                (otherwise (error "Couldnt parse ~a, of type ~a!"
                                  instance (type-of instance))))))
  (let* ((instance-list (first lists))
         (var-list (second lists))
         (where (position instance instance-list :test #'equal)))
(if (null where)
(progn (format t "~a was not on the seen list!, creating!~%" instance)
(case (%type-of instance)
(STRUCTURE
(return-from get-instance-label
 (allocate-struct (get-defstruct-type instance))))))
(return-from get-instance-label  (nth where var-list))))))

(defun DO-VAR-TYPE-CELLS (vars insts)
""
(mapcar #'(lambda (a b)(list a b))
vars insts))

(defun MAPAPPEND (fun &rest args)
"From the MOP book!"
(if (some #'null args)
    ()
  (append (apply fun (mapcar #'car args))
      (apply #'mapappend fun (mapcar #'cdr args)))))

(defun ALL-INSTANCE-LIST-P (x)
"Predicate for a list containing only instances!"
(and (listp x) (every #'instance-p x)))

(defun MAKE-VAR-TYPE-CELLS (vars insts &optional plists samep)
"An auxilary function for MAKE-LET-FORM..."
(let ((htab-plist (if samep (mapcar #'get-dump-form (first plists))))
      (count -1))
(mapappend
     #'(lambda (cell)
         (incf count)
         (list (list (first cell)
                     (append
             (list '%allocate-instance
               `(QUOTE ,(instance-name (second cell))))
                        (if samep htab-plist
                  (mapcar #'get-dump-form
                      (nth count plists)))))))
      (do-var-type-cells vars insts))))

(defun SAMESET (l1 l2 &key (test #'equal))
"predicate, returns t if the two sets contain the same elements."
(and (subsetp l1 l2 :test test)(subsetp l2 l1 :test test)))

(defun SAME-KEYWORDS-P (p1 p2)
"Predicate:"
(if (or (not (listp p1))(not (listp p2))) nil
(sameset (get-evens p1)(get-evens p2))))

(defun MAPPLIST (fun x)
"From the MOP book!"
(if (null x) nil (cons (funcall fun (first x)(second x))
               (mapplist fun (cddr x)))))

(defun SAME-PLIST-VALUES-P (p1 p2)
"Use mapplist from the MOP book!"
(let ((kwds1 (get-evens p1))
      (kwds2 (get-evens p2)))
(if (not (sameset kwds1 kwds2))
    nil
(dolist (kwd kwds1 T)
   (when (not (equal (getf p1 kwd)(getf p2 kwd))) (return nil))))))

(defun UNORDERED-PLIST-EQUAL (p1 p2)
"predicate to tell if plist keywords & values are equal,
 regardless of attribute pair ordering."
(and (same-keywords-p p1 p2)(same-plist-values-p p1 p2)))

(defun ALL-HTAB-PLISTS-SAMEP (htab-plist-list)
"Predicate: does set equality on plists."
(every #'(lambda (plist)(unordered-plist-equal plist
                 (first htab-plist-list)))
       (rest htab-plist-list)))

(defun MAKE-HTAB-PLIST (htab)
"makes a plist for a hash tables inner attributes!"
(list :size (hash-table-size htab)
      :rehash-size (hash-table-rehash-size htab)
      :test (hash-table-test htab)
      :rehash-threshold (hash-table-rehash-threshold htab)))

(defun MAKE-HTAB-PLISTS (list-o-htabs)
"takes a list of htabs: checks to see if the plists are the same,
multiple value return of the attribute plist(s), and whether they
are the same (T or NIL)."
(let ((answers nil)(new-plist nil))
(dolist (htab list-o-htabs answers)
 (setf new-plist (make-htab-plist htab))
 (push new-plist answers))
(let ((samep (all-htab-plists-samep list-o-htabs)))
(if samep (values (list (first answers)) T)
  (values answers NIL)))))

(defun MAKE-ILIST-VAR-TYPE-CELLS (to-be-saved-list)
(delete nil (make-var-type-cells *vars* *seen*)))

(defun MAKE-LIST-VAR-TYPE-CELLS (to-be-saved-list)
"SEQUENCES need the whole ball of wax."
(declare (ignore to-be-saved-list))
(multiple-value-bind (plists samep)
(make-htab-plists *htabs-seen*)
(let* ((insts (make-var-type-cells *vars* *seen*))
       (structs (make-var-type-cells *struct-vars* *structs-seen*))
       (htabs (make-var-type-cells *htab-vars* *htabs-seen*
                   plists samep))
       (end-result (NCONC insts structs htabs)))
(when *debug-local-bindings* (format t "~%~A~%" end-result))
       (delete nil end-result))))

(defun MAKE-LET-FORM (object &optional other-code)
"This functions constructs the lexical environment for the text representation of
LISP objects --- without this, there could be no self refererence!"
(cond ((equal (%type-of object) 'instance)
`(let* ,(make-list-var-type-cells object)
        ,other-code))
      ((equal (%type-of object) 'structure)
`(let* ,(make-list-var-type-cells object)
        ,other-code))
      ((equal (%type-of object) 'hash-table)
`(let* ,(make-list-var-type-cells object)
          ,other-code))
      ((equal (%type-of object) 'circular-list)
       `(progn ,other-code))
      ((equal (%type-of object) 'vector)
`(let* ,(make-list-var-type-cells object) ,other-code))
      ((equal (%type-of object) 'array)
`(let* ,(make-list-var-type-cells object) ,other-code))
      ((cons-p object)
`(let* ,(make-list-var-type-cells object) ,other-code))
      ((simple-list-p object)`(progn ,other-code))
      ((quoted-list-p object)`(progn ,other-code))
      ((all-instance-list-p object)
`(let* ,(make-ilist-var-type-cells object)
            ,other-code))
      ((LISTP object)
`(let* ,(make-list-var-type-cells object)
            ,other-code))
(T (warn "FROM MAKE LET FORM: object was of bogus type: ~A!!!"
     (%type-of object))
   (if other-code `(progn ,other-code)
       (progn (warn "there was no code to enclose!") nil)))))

#-(or lispm lucid allegro-v4.0 akcl)
(defun FILL-ARRAY (array l)
"Fill n-dimensional array with values from list."
(let ((list (flatten l)))
(if (= 1 (length (array-dimensions array)))
    (loop for count from 0 to (1- (length array)) do
      (setf (aref array count)(nth count list))
      finally (return-from fill-array array))
(progn (dotimes (i (array-total-size array) array)
       (setf (row-major-aref array i)(nth i list)))
    (return-from fill-array array)))))

#+(or allegro-v4.0 akcl)
(defun FILL-ARRAY (array l)
"Fill n-dimensional array with values from list."
(let ((list (flatten l)))
(dotimes (i (array-total-size array) array)
       (setf (row-major-aref array i)(nth i list)))
    (return-from fill-array array)))

#+lispm
(defun FILL-ARRAY (array l)
"Fill n-dimensional array with values from list."
(let ((list (flatten l))(array array))
(declare (sys:array-register array))
(if (= 1 (length (array-dimensions array)))
    (loop for count from 0 to (1- (length array)) do
      (setf (si:%1d-aref array count)(nth count list))
      finally (return-from fill-array array))
(progn  (dotimes (i (array-total-size array) array)
       (setf (row-major-aref array i)(nth i list)))
    (return-from fill-array array)))))

#-lucid
(defun MAPARRAY (function array)
"like mapcar, but maps a function over each element of an
n-dim array: the function to be applied is a function of two args,
the count and the element value at aref count in the array."
(let ((array array))
#+lispm (declare (sys:array-register-1d array))
(if (= 1 (length (array-dimensions array)))
    (dotimes (count (1- (length array)) array)
#+lispm(setf (sys:%1d-aref array count)(funcall function count (sys:%1d-aref array count)))
#-lispm(setf (aref array count)(funcall function count (aref array count)))
)
(progn  (dotimes (i (array-total-size array) array)
       (setf (row-major-aref array i)
         (funcall function i (aref array i))))
    (return-from maparray array)))))

(defun ARRAY-TYPE-T-P (X)
"Predicate, checks type and element-type of x."
(and (arrayp x)(not (stringp x))(equal (array-element-type x) T)))

(defun %TYPE-OF (x)
"Special type-of operator, returning a more intellignet type  for object caching:"
(cond ((%classp x) 'class)
      ((instance-p x) 'instance)
      ((structure-p x) 'structure)
      ((hash-table-p x) 'hash-table)
      ((typep x 'vector) 'vector)
      ((array-type-t-p x) 'array-type-t)
      ((arrayp x) 'array)
      ((cons-p x) 'cons)
      ((listp x)(if (circular-list-p x) 'circular-list 'list))
      (T (type-of x))))

(defun LOOKUP-OBJECT (X &key (mode :save))
"Accessor to the global object hashtable."
(rassoc x (gethash (%type-of x)(if (equal mode :save)
                 *save-object-hash-table*
                   *load-object-hash-table*))
 :test #'equalp))

(defun CACHE-OBJECT (x &key (mode :save))
"If the object is a structured object, cache the object in the object
hash table, if it isnt already there, along with its variable designation."
"If the object is a structured object, cache the object in the object
hash table, if it isnt already there, along with its variable designation."
(push (CONS (makevar) x) (gethash (%type-of x)
(if (equal mode :save) *save-object-hash-table*
  *load-object-hash-table*)))
x)

(defun LOOKUP-OBJECT-OR-CACHE (x)
""
(cond ((null (lookup-object (eval x) :mode :load))
       (cache-object (eval x) :mode :load))
      (T x)))

(defun %%LIST-LENGTH (x)
""
(cond ((cons-p x)(length x))
      ((listp x)(list-length x))
      (T NIL)))

(defun %LIST-LENGTH (x)
"Differs from ClTl2 LIST-LENGTH in that a multiple value return of
NIL and counter value are returned if its a circular list."
 (cond ((cons-p x)(length x))
      ((listp x)(do (( n 0 (+ n 2))
     (fast x (cddr fast))
     (slow x (cdr slow)))
     (nil)
(when (endp fast)(return (values n nil)))
(when (endp (cdr fast))(return (values (1+ n) nil)))
(when (and (eq fast slow)(> n 0))(return (values nil (/ n 2))))))
(T (values nil nil))))

(defun FIRSTN (n list)
"Return the first n elements of a list."
(let ((answers nil))
(dotimes (count (1- n) answers)
     (push (nth count list) answers))
(nreverse answers)))

(defun GET-CIRCULAR-LIST-ELEMENTS (circular-list)
"Given a circular list, get the repeating pattern."
(if (circular-list-p circular-list)
    (multiple-value-bind (status len)
    (%list-length circular-list)
       status
      (firstn len circular-list))
    circular-list))

(defun MAKE-CIRCULAR-LIST (elts)
"Given non circular list elements elts, return a circular list of those elements."
 (rplacd (last elts) elts))

(defun CIRCULAR-LIST-DUMP-FORM (clist)
""
(let ((ones (get-dump-form (get-circular-list-elements clist))))
  `(make-circular-list ,ones)))

(defun CIRCULAR-LIST-LENGTH (clist)
"Given a circular list, returns the number of non-circular elements before cycle:
returns an error if this is not a circular list!"
(multiple-value-bind (status length)
(%list-length clist)
(when status (error "this is not a circular list!"))
length))

(defun CIRCULAR-LIST-EQUAL (a b)
""
(and (equal (circular-list-length a)(circular-list-length b))
     (equal (get-circular-list-elements a)(get-circular-list-elements b))))

(defun CIRCULAR-CONS-P (X)
(and (circular-list-p x)
     (eq (rest x) x)))

(defun CIRCULAR-CONS-DUMP-FORM (instance)
`(let ((first ,(get-dump-form (list (first instance)))))
  (setf (rest first) first)))

(defun CIRCULAR-LIST-P (X)
"Predicate to determine if something is a circular list, uses
LIST-LENGTH, which, unlike LENGTH, terminates and returns NIL if
the list is circular: LIST-LENGTH may not be in all versions of
LISP, as it is CLtL2: CHANGED TO INCLUDE THE RECURSIVE DEFINITION
OF CIRCULAR LISTS."
(if (not (listp x)) nil
(or (null (list-length x))(some #'circular-list-p x))))

(defun PCO-P (instance)
"A predicate to determine if a LISP object is a PCO."
(and (not (stringp instance))(member (%type-of instance) *pco-types*)))

(defun OBJECT-VAR (some-object &optional mode)
"The structure of the object htabs entries is (key . object),
 finding the cell with lookup-object, then the first element of the CONS!"
(if (null mode)(setf mode *mode-for-object-var*))
(let ((lo (lookup-object some-object :mode *mode-for-object-var*)))
(setf lo
(cond ((null lo)(warn "couldnt find ~a in object var!" some-object) NIL)
      ((listp lo)(first lo))
      (T lo)))))

(defun SET-OBJECT-VAR (object new-var)
"Given object and new var, and mode, set the appropriate hash table
key/value to the new-var."
(let* ((mode *mode-for-set-object-var*)
(there (lookup-object object :mode mode)))
(when (not there)(cache-object object :mode *mode-for-object-var*))
(rplaca (lookup-object object :mode *mode-for-object-var*)(object-var new-var))))

(defsetf object-var set-object-var)

(defun MAP-NONCIRCULAR-ELEMENTS-AND-COPY (function circ-list)
""
(let ((elts (mapcar function
   (copy-list (get-circular-list-elements circ-list)))))
(make-circular-list elts)))

(defun MAP-OBJECT (function object)
"Generalized iterator for PCOs."
(cond ((circular-list-p object)
       (map-noncircular-elements-and-copy function object))
      ((vectorp object)
       #-(or akcl allegro-v4.0)
         (loop for count from 0 to (1- (length object)) do
         (setf (aref object count)
           (funcall function (aref object count)))
         finally (return object))
       #+(or akcl allegro-v4.0)
       (dotimes (count (1- (length object)) object)
       (setf (aref object count)(funcall function (aref object count))))
       )
      ((arrayp object)(maparray function object))
      ((structure-p object)(mapstruct function object))
      ((hash-table-p object)(maphash #'(lambda (key val)
                (setf (gethash key object)
                  (funcall function val)))
                     object) object)
      ((instance-p object)(map-instance function object))
      (T (warn "Couldnt deal with object ~a, type: ~a.~%"
           object (type-of object)))))

;;;  *** Beginning of CLOS eval-when... ***

#+clos
(eval-when (load eval compile)

;;; *** Dont-care vendor CLOS definitions. ***

(defun GET-CLASS-METACLASS (class-object)
"Given a class object, returns the metaclass name to help build
 CLASS-DUMP-FORM:  (NEW)."
(when (%classp class-object)
(let ((meta (%class-name (class-of (class-of class-object)))))
(if (not (equal meta 'clos::standard-class)) ;;; the default...
(list (list :metaclass meta))))))

(defun GET-CLASS-DOCUMENTATION (c)
""
(or (documentation c) ""))

(defmethod INSTANCE-NAME ((instance T))
  "returns the symbol naming the given class object.
   NOTE: on the slimbolical hash-tables are FLAVORS.
   Therefore one must use HASH-TABLE-P instead of TYPE-OF,
   and the type returned is a Common Lisp entity, NOT a FLAVOR!"
(cond ((hash-table-p instance) 'hash-table)
      ((equal (%type-of instance) 'structure)(type-of instance))
      (T (clos::class-name (clos::class-of instance)))))

;;; *** BEGINNING OF NON-MCL definitions! ***

#-(or akcl :mcl)
(eval-when (eval load compile)

(defun HAS-DUMP-FORM-P (class-name)
  "Predicate, returns t if a class has a user-defined DUMP FORM method."
  (get class-name 'user::%%DUMP-FORM-METHOD%%))

(defmacro DEFINE-DUMP-FORM (class-name arglist &body body)
  "Macro to define a user-defined dump-form for a given class-name.
   You could do this as two discrete steps, programmatically where you need it."
  `(progn (setf (get ',class-name 'user::%%dump-form-method%%) T)
      (defmethod DUMP-FORM ,arglist ,@body)
      ',class-name))

(defun GET-CLASS-DEFAULT-INITARGS (class)
"Gets the default-initargs out of the class object."
(mapcan #'(lambda (l)(list (first l)(get-dump-form (third l))))
(clos::class-direct-default-initargs class)))

(defmethod ALL-SLOTNAMES ((instance T) &optional (all-allocations T))
  "returns the names of the slots in instance, uses what MOP stuff is available."
(declare (ignore all-allocations))
(mapcar #'clos::slot-definition-name
    (clos::class-DIRECT-slots (clos::class-of instance))))
                 ;;;;******

) ;;; end of non-MCL definitions eval-when...

;;; *** beginning of MCL common lisp definitions...***

#+:mcl
(eval-when (compile load eval)

(defun HAS-DUMP-FORM-P (class-name)
  "Predicate, returns t if a class has a user-defined DUMP FORM method."
  (get class-name '%%DUMP-FORM-METHOD%%))

(defmacro DEFINE-DUMP-FORM (class-name arglist &body body)
  "Macro to define a user-defined dump-form for a given class-name.
   You could do this as two discrete steps, programmatically where you need it."
  `(progn (setf (get ',class-name '%%dump-form-method%%) T)
      (defmethod DUMP-FORM ,arglist ,@body)
      ',class-name))

(defun CLASS-SLOTNAMES (class-object)
"Calls the clos internal function to compute class slot names."
(remove nil (mapcar #'first (class-slots class-object))))

(defun CLASS-SLOTS (class)
"MODIFIED: Given a class object, return all the slot objects."
#+supra (ccl::class-instance-slots class)
#+fx (ccl::class-slots class)
#+mcl2.0f3(class-direct-slots class)
)
;;; ---- new experimental routines for MCL2.0f3 ------

#-mcl2.0f3
(defun CLASS-DIRECT-SLOTS (class)
"Given a class object return the slot objects."
(ccl::class-direct-slots class))

#+mcl2.0f3
(defun CLASS-DIRECT-SLOTS (class)
"Given a class object return the slot objects."
(ccl::class-direct-class-slots class))

(defun GET-DEFSTRUCT-CONSTRUCTOR (name)
"default definition for now...."
(read-from-string (concatenate 'string "make-" (format nil "~a" name))))

(defun INSTANCE-P (X)
"Predicate to determine whether something is an INSTANCE."
(and (not (%classp x))(typep x 'standard-object)))

(defun STRUCTURE-P (X)
"Predicate to determine whether something is a structure INSTANCE."
(ccl:structurep x))

(defun GET-CLASS-DEFAULT-INITARGS (class)
"Gets the default-initargs out of the class object."
class
nil)

(defun %CLASSP (X)
"predicate to tell if something is a class object."
(typep x 'ccl::standard-class))

(defun %GENERIC-FUNCTION-DOCUMENTATION (f)
""
(or (documentation f) ""))

(defun GET-SLOT-TYPE (S)
""
(first (reverse s)))

(defun GET-DIRECT-SLOTS (class-object)
"Gets the immediately available 'new' non inheried slot OBJECTS."
(class-direct-slots class-object))

(defun GET-SLOT-DOCUMENTATION (s)
""
(or (documentation s) ""))

(defun GET-SLOT-NAME (S)
"Method to get the name from a standard slot."
(clos::slot-definition-name s))

(defun SLOT-HAS-AN-INITFORM-P (slot-object)
""
(second slot-object))

(defun GET-SLOT-READERS (s)
""
s
nil)

(defun GET-SLOT-WRITERS (s)
""
s
nil)

(defun %SLOT-DEFINITION-ALLOCATION (S)
""
s
NIL)

(defun GET-SLOT-NAMED (instance name)
""
(find-if #'(lambda (slot)
(equal (get-slot-name slot) name))
     (all-slots instance)))

(defun GET-SLOT-ALLOCATION (S)
"Method to get the type of allocation from a standard slot: oneof :CLASS or :INSTANCE."
(let ((alloc (%slot-definition-allocation s)))
(cond ((%classp alloc) :CLASS)
      ((member alloc '(:INSTANCE :CLASS)) alloc)
      (T :INSTANCE))))

(defmethod GET-SLOT-INITFORM (s)
""
(when (slot-has-an-initform-p s)
(first (second s))))

(defun %GET-SLOT-INITFORM (S)
"Method to create the iniform pair, if there is an initform value!"
(if  *save-contents-of-class-allocated-classes*
(when (and (equal (get-slot-allocation s) :CLASS)
       (slot-has-an-initform-p s))
(list :initform (get-dump-form (funcall (get-slot-reader s) s)))))
(when (slot-has-an-initform-p s)
(list :initform  (get-slot-initform s))))

(defun GET-SLOT-INITARGS (s)
""
(ccl::class-slot-initargs s))

(defun GET-SLOT-INITARG (s)
""
(first (ccl::class-slot-initargs s)))

(defmethod ALL-SLOTNAMES ((instance T) &optional (all-allocations T))
  "returns the names of the slots in instance, uses what MOP stuff is available."
(declare (ignore all-allocations))
(REMOVE NIL (mapcar #'clos::slot-definition-name
                (class-slots (clos::class-of instance)))))

(defun ALL-SLOTS (instance)
"Gets all the slots from the instances class, whether inherited or not."
(class-slots (clos::class-of instance)))

(defun %CLASS-NAME (x)
"If instance, gets the name of the class of the instance."
(if (instance-p x)(clos::class-name (clos::class-of x))
(clos::class-name x)))

(defun GET-SUPERCLASS-NAMES (class)
""
(mapcar #'clos::class-name (clos::class-direct-superclasses class)))

) ;;; *END OF MCL CCL CLOS eval-when! ****

;;; *** Non-LISP machine CLOS eval-when. ***

#-(or lispm :mcl akcl)
(eval-when (load compile eval)

(defun %GENERIC-FUNCTION-DOCUMENTATION (f)
""
(or (documentation f) ""))

(defun GET-SLOT-TYPE (S)
"Method to get the type from a standard slot:
 this works for most things EXCEPT Genera 8x CLOS."
(clos::slotd-type s))

;;;;(defun GET-DIRECT-SLOTS (class-object)
;;;""
;;;(clos::class-class-direct-slots class-object))

(defun %GENERIC-FUNCTION-P (x)
"Predicate, returns t for generic functions. causes symbol conflict problem
 in genera 8.0."
(clos::generic-function-p x))

)

;;; *** END OF NON LISPM EVAL-WHEN ***

;;; *** Lisp Machine Genera 8.x CLOS eval-when. ***

#+lispm
(eval-when (load eval compile)

(defun %GENERIC-FUNCTION-P (x)
"Predicate, returns t for generic functions. causes symbol conflict problem
 in genera 8.0."
(clos-internals::generic-function-p x))

(defun BUILTIN-CLASS-P (class-object)
"Predicate to determine whether a class object (that which is returned by (FIND-CLASS <NAME>))
 is a BUILTIN class or not."
(typep class-object 'clos:built-in-class))

(defmethod CLASS-NAME ((object t))
"We use this in %classp. we already know its either an instance or a class.
 if its an instance, it has no name. CLASS-NAME on standard class takes care of real
 class objects."
nil)

(defun %CLASSP (X)
"The function CLASSP is not defined at all in Genera."
(and (instance-p x)(find-class (class-name x) nil)))

(defun %GENERIC-FUNCTION-DOCUMENTATION (f)
""
(or (documentation f) ""))

(defun INSTANCE-P (x)
"This will work in Genera 8x CLOSes: filters out entities that are flavor instances.
 Also filters out things that are defstruct instances."
(and (sys:instancep x)(not (flavor:find-flavor (type-of x) nil))))

(defun GET-SLOT-TYPE (S)
"This will work for Genera 8x CLOSses."
(clos:slot-definition-type s))

(defun GET-DIRECT-SLOTS (class-object)
""
(clos:class-direct-slots class-object))

(defun GET-SLOT-DOCUMENTATION (s)
""
(or (documentation s) ""))

(defun GET-SLOT-NAME (S)
"Method to get the name from a standard slot."
(clos::slot-definition-name s))

(defun SLOT-HAS-AN-INITFORM-P (slot-object)
  (clos::slot-definition-initform slot-object))

(defun GET-SLOT-READERS (slot-object)
  (clos::slot-definition-readers slot-object))

(defun GET-SLOT-WRITERS (slot-object)
  (clos::slot-definition-writers slot-object))

(defun GET-SLOT-NAMED (instance name)
(find-if #'(lambda (slot)(equal (get-slot-name slot) name))
     (all-slots instance)))

(defun GET-SLOT-ALLOCATION (S)
"Method to get the type of allocation from a standard slot: oneof :CLASS or :INSTANCE."
(let ((alloc (clos::slot-definition-allocation s)))
(cond ((%classp alloc) :CLASS)
      ((member alloc '(:INSTANCE :CLASS)) alloc)
      (T :INSTANCE))))

(defmethod GET-SLOT-INITFORM (s)
""
(when (slot-has-an-initform-p s)(clos::slot-definition-initform s)))

(defun %GET-SLOT-INITFORM (S)
"Method to create the iniform pair, if there is an initform value!"
(if  *save-contents-of-class-allocated-classes*
(when (and (equal (get-slot-allocation s) :CLASS)
       (slot-has-an-initform-p s))
(list :initform (get-dump-form (funcall (get-slot-reader s) s)))))
(when (slot-has-an-initform-p s)
(list :initform  (clos::slot-definition-initform s))))

(defun GET-SLOT-INITARGS (s)
(clos::slot-definition-initargs s))

(defun GET-SLOT-INITARG (s)
(first (clos::slot-definition-initargs s)))

) ;;; end of Genera 8x CLOS eval-when.

;;; Lucid CLOS eval when...

#+lucid
(eval-when (load eval compile)

(defun MAPARRAY (function array)
"like mapcar, but maps a function over each element of an
n-dim array: the function to be applied is a function of two args,
the count and the element value at aref count in the array."
(let* ((vec (sys:underlying-simple-vector array))
      (len (1- (length vec))))
(loop for count from 0 to len do (setf (aref vec count)
  (funcall function count (aref vec count)))
  finally (return array))))

(defun FILL-ARRAY (array l)
"Fill n-dimensional array with values from list."
(let* ((vec (sys:underlying-simple-vector array))
       (len (1- (length vec)))
       (data (flatten l)))
(loop for index from 0 to len
do (setf (aref vec index)(nth index data))
  finally (return array))))

(defun GET-SUPERCLASS-NAMES (class)
"Expects the object returned by FIND-CLASS."
(mapcar #'clos::class-name (clos::class-direct-superclasses class)))

(defun INSTANCE-P (x)
"Alternate def as a function for lucid 4.0."
(and (system:standard-object-p x)(not (system:classp x))))

(defun GET-SLOT-DOCUMENTATION (s)
""
(or (clos::slotd-documentation s) ""))

(defun GET-SLOT-NAME (S)
"Method to get the name from a standard slot."
(clos::slotd-name s))

(defun GET-SLOT-READERS (slot-object)
  (clos::slotd-readers slot-object))

(defun GET-SLOT-WRITERS (slot-object)
  (clos::slotd-writers slot-object))

(defun GET-SLOT-ALLOCATION (S)
"Method to get the type of allocation from a standard slot: oneof :CLASS or :INSTANCE."
(let ((alloc (clos::slotd-allocation s)))
(cond ((%classp alloc) :CLASS)
      ((member alloc '(:INSTANCE :CLASS)) alloc)
      (T :INSTANCE))))

(defun %CLASSP (X)
"CLASSP is not exported in Lucid or EXCL, and is not defined at all in Genera!"
(clos::classp x))

(defmethod GET-SLOT-INITFORM (s)
""
(when (slot-boundp s 'clos::initform)
       (clos::slotd-initform s)))

(defun %GET-SLOT-INITFORM (S)
"Method to create the iniform pair, if there is an initform value!"
(if  *save-contents-of-class-allocated-classes*
(when (and (equal (get-slot-allocation s) :CLASS)
       (slot-boundp s 'clos::initform))
(list :initform (get-dump-form (funcall (get-slot-reader s) s))))
(when (slot-boundp s 'clos::initform)
      (list :initform  (clos::slotd-initform s)))))

(defun GET-SLOT-INITARGS (s)
(clos::slotd-initargs s))

(defun GET-SLOT-INITARG (s)
(first (clos::slotd-initargs s)))

(defun BUILTIN-CLASS-P (X)
  "Predicate to determine whether a class object is a builtin class. returns
   T if it is."
  (and (%classp x)(member (%class-name x)
  (mapcar #'first clos-system::built-in-classes) :test #'equal)))

) ;;; *** end of Lucid CLOS eval-when. ***

;;; *** Allegro non-MCL eval-when (e.g. on Suns.) ***

#+excl
(eval-when (load eval compile)

(defun GET-SLOT-DOCUMENTATION (s)
""
(or (documentation s) ""))

(defun GET-SLOT-READERS (slot-object)
  (clos::slotd-readers slot-object))

(defun GET-SLOT-WRITERS (slot-object)
  (clos::slotd-writers slot-object))

(defun GET-SLOT-ALLOCATION (S)
"Method to get the type of allocation from a standard slot: oneof :CLASS or :INSTANCE."
(let ((alloc (clos::slotd-allocation s)))
(cond ((%classp alloc) :CLASS)
      ((member alloc '(:INSTANCE :CLASS)) alloc)
      (T :INSTANCE))))

(defun GET-SLOT-NAME (S)
"Method to get the name from a standard slot."
(clos::slotd-name s))

(defun %CLASSP (X)
""
(or (typep x 'clos::standard-class)(typep x 'clos::built-in-class)))

(defmethod GET-SLOT-INITFORM (s)
""
(when (slot-boundp s 'clos::initform)
       (clos::slotd-initform s)))

(defun %GET-SLOT-INITFORM (S)
"Method to create the iniform pair, if there is an initform value!"
(if  *save-contents-of-class-allocated-classes*
(when (and (equal (get-slot-allocation s) :CLASS)
       (slot-boundp s 'clos::initform))
(list :initform (get-dump-form (funcall (get-slot-reader s) s))))
(when (slot-boundp s 'clos::initform)
      (list :initform  (clos::slotd-initform s)))))

(defun GET-SLOT-INITARGS (s)
(clos::slotd-initargs s))

(defun GET-SLOT-INITARG (s)
(first (clos::slotd-initargs s)))

(defun BUILTIN-CLASS-P (X)
  "Predicate to determine whether a class object is a builtin class. returns
   T if it is."
(and (%classp x)(typep x 'clos::built-in-class)))

#+allegro-v4.1
(defun INSTANCE-P (X)
"With the 4.0 series, structures are instances as well: exclude these."
(and (not (typep x 'clos::structure-class))
 (not (%classp x))(excl::standard-instance-p x)))

#+allegro-v4.0
(defun INSTANCE-P (X)
"With the 4.0 series, structures are instances as well: exclude these:
 NOTE, removed the clause testing for clos:structure-object."
 (not (%classp x))(excl::standard-instance-p x))

) ;;; *** end of non-MCL Allegro (like Sun Allegro) CLOS eval-when. ***

) ;;; *** END OF CLOS EVAL WHEN *******

;;; PCL Dependent functions & methods,,,

#+pcl
(eval-when (load eval compile)

(defun INSTANCE-NAME (instance)
  "returns the symbol naming the given class object."
  (pcl::class-name (pcl::class-of instance)))

(defun ALL-SLOTNAMES (instance &optional (all-allocations T))
  "returns the names of the slots in instance."
(let ((them (mapcar #'(lambda (slot)
            (pcl::slot-value slot 'pcl::name))
          (pcl::slots-to-inspect (pcl::class-of instance)
                 instance))))
(if all-allocations them
      (remove-if-not #'(lambda (slot)
          (equal (pcl::slotd-allocation slot) :instance))
                  them))))

(defun ALL-SLOTS (instance &optional (all-allocations T))
  "returns the names of the slots in instance."
(let ((them (pcl::slots-to-inspect (pcl::class-of instance)
                 instance)))
(if all-allocations them
      (remove-if-not #'(lambda (slot)
          (equal (pcl::slotd-allocation slot) :instance))
                  them))))

) ;;; *** END PCL EVAL-WHEN.... ***

;;; Independent.

(defun GET-CLASS-SUPERCLASSES (class)
"Returns a list of the NAMES (symbol list) of the direct superclasses of the class object."
(let ((the-ones (get-superclass-names class)))
  (if *supress-standard-object* (delete 'standard-object the-ones)
    the-ones)))

(defun GET-SLOT-READER (slot-object)
  (first (get-slot-readers slot-object)))

(defun GET-SLOT-WRITER (slot-object)
  (first (get-slot-writers slot-object)))

(defun ACCESSOR-EXISTS-P (S)
"Predicate: Returns T iff the slot has both a reader and a standard writer."
(let* ((readers (get-slot-readers s))
       (writers (get-slot-writers s))
       (accessors (some #'(lambda (writer)
                (and (listp writer)
                 (equal (first writer) 'SETF)
                 (second writer)
                 (member (second writer) readers
                     :test #'equal)))
            writers)))
  accessors))

(defun GET-SLOT-ACCESSOR (s)
"Returns the first slot accessor alone."
(let ((val  (first (get-slot-readers s))))
(when (and val (accessor-exists-p s))
      val)))

(defun %GET-SLOT-NAME (S)
"Method to get the name from a standard slot."
(get-slot-name s))

(defun %GET-SLOT-ALLOCATION (S)
"Method to get the type of allocation from a standard slot: oneof :CLASS or :INSTANCE."
(let ((val  (get-slot-allocation s)))
(when val (list :allocation val))))

(defun %GET-SLOT-TYPE (S)
"Method to get the type from a standard slot.."
(list :type (get-slot-type s)))

(defun %GET-SLOT-INITARG (S)
"Method to get the first initarg found for the standard slot instance supplied."
(let ((val (or (first (get-slot-initargs s))
(if *use-default-class-initargs* (make-keyword (get-slot-name s))))))
(when val (list :initarg val))))

(defun %GET-SLOT-READER (slot)
"Method to determine whether to use an accessor or a reader. Does not splice
 into the dump form if there is no reader defined."
(when (null (%get-slot-accessor slot))
  (let ((val  (GET-SLOT-reader slot)))
    (when val (list :reader val)))))

(defun %GET-SLOT-WRITER (slot)
"Method to determine whether to use an accessor or a writer. Does not splice
 into the dump form if there is no writer defined."
(when (null (%get-slot-accessor slot))
  (let ((val (GET-SLOT-WRITER slot)))
      (when val (list :writer val)))))

(defun %GET-SLOT-DOCUMENTATION (S)
""
(list :documentation (or (GET-SLOT-DOCUMENTATION s) "")))

(defun %GET-SLOT-ACCESSOR (S)
""
(let ((val  (GET-SLOT-READER s)))
(when (and val (accessor-exists-p s))
      (list :accessor val))))

(defmethod METHODP ((thing null))
"NIL is not a method."
nil)

(defmethod METHODP ((thing t))
"Anything else is not a method."
  nil)

(defmethod MBOUNDP ((name symbol))
  "Predicate: returns t if this name is a method as opposed to a function/macro."
  (when (methodp name) T))

(defmethod MBOUNDP ((name null))
"vacuous case for NIL."
NIL)

(defmethod MBOUNDP ((name t))
  "Predicate: returns t if this name is a method as opposed to a function/macro."
  (when (methodp name) T))

(defun SLOT-DATA-AS-PLIST (slot)
"Generates the slot value pairs of the slot descriptor as a property list,
 of course the name is stuck on the front."
(let ((name (get-slot-name slot))
      (initarg (get-slot-initarg slot))
      (accessor (get-slot-accessor slot))
      (initform (get-slot-initform slot))
      (type (get-slot-type slot))
      (documentation (get-slot-documentation slot))
      (allocation (get-slot-allocation slot)))
(if accessor
(list name :initarg initarg
      :accessor accessor
      :initform initform
      :type type
      :documentation documentation
      :allocation allocation)
(list name :initarg initarg
      :initform initform
      :type type
      :documentation documentation
      :allocation allocation))))

(defun CONSTRUCT-SLOT-SPEC (slot)
"The internal dump-form constructor for slots."
(let ((name (%get-slot-name slot))
      (initarg-pair (%get-slot-initarg slot))
      (type-pair (%get-slot-type slot))
      (accessor-pair (%get-slot-accessor slot))
      (reader-pair (%get-slot-reader slot))
      (writer-pair (%get-slot-writer slot))
      (allocation-pair (%get-slot-allocation slot))
      (initform-pair (%get-slot-initform slot))
      (documentation-pair (%get-slot-documentation slot)))
  `(,name ,@initarg-pair
    ,@type-pair
    ,@accessor-pair
    ,@reader-pair
    ,@writer-pair
    ,@allocation-pair
    ,@initform-pair
    ,@documentation-pair)))

(defun GENERATE-CLASS-SLOT-FORM (slotd)
"Default method for rev4b --- seems to be defective...
 This one gets called by CLASS-DUMP-FORM."
(construct-slot-spec slotd))

(defun SORT-ALLOCATED-SLOTS (class-object)
""
(let ((slots (class-slots class-object)))
(values
(remove-if-not #'(lambda (slot)(equal (get-slot-allocation slot)
                      :CLASS))
           slots)
(remove-if-not #'(lambda (slot)(equal (get-slot-allocation slot)
                      :INSTANCE))
           slots))))

;;;; Only allow class save, method save, and generic function save when this
;;; file is loaded: control this with :class-save on the features list.
;;; end of lucid eval-when.

;;; NOTE! Returned result from CLASS-DIRECT-SLOTS varies with the vendor!

#-(or :mcl lucid lispm akcl)
(defun CLASS-SLOTS (class-object)
"Calls the clos internal function to compute class slot objects."
(clos::class-direct-slots class-object))

;;; CLOS/PCL independent class accessor methods.

(eval-when (load eval compile)

(defun DO-SPECIALIZER (spec)
"Map objects to class names."
(cond ((SYMBOLP SPEC) spec)
      ((%CLASSP SPEC)`(FIND-CLASS ',(%class-name spec)))
      (T SPEC)))



#-(or allegro-v4.0 akcl)
(defun DO-SPECIALIZERS (lst)
(loop for spec in lst collect (do-specializer spec)))

#+(or allegro-v4.0 akcl)
(defun DO-SPECIALIZERS (lst)
(let ((answers nil))
(dolist (spec lst answers)
    (setf answers (append (list (do-specializer spec)))))
answers))

(defun FIND-GENERIC-FUNCTION (name)
"A function given the name of a supposed generic function,
 returns the function object if it exists, NIL otherwise."
(cond ((and (fboundp name)(%generic-function-p name))
       (symbol-function name))
      (T NIL)))



(defun GENERATE-CLASS-OPTIONS-FORM (class)
"Generates a dump form for the default-initargs, metaclass,
 documentation components of a class object...."
(let ((default-initargs (get-class-default-initargs class))
      (metaclass (get-class-metaclass class)))
  (if default-initargs
      `((:default-initargs ,@default-initargs)
    ,@metaclass
    (:documentation ,(or (get-class-documentation class) "")))
    `(,@metaclass
      (:documentation ,(or (get-class-documentation class) ""))))))

#+(or akcl allegro-v4.0)
(defun GENERATE-CLASS-SLOT-FORMS (class)
"This generates dump forms for all the slots in the class object."
(let ((slots nil))
(dolist (slot (class-slots class) slots)
      (setf slots (append slots
      (list (generate-class-slot-form slot)))))
slots))

#-(or akcl allegro-v4.0)
(defun GENERATE-CLASS-SLOT-FORMS (class)
"This generates dump forms for all the slots in the class object."
(loop for slot in (class-slots class)
      collect (generate-class-slot-form slot)))

) ;;; end of class-save eval-when.


;;; Now, the Symbolics....

#+lispm
(defun HASH-TABLE-SIZE (x)
(scl:send x :size))

#+lispm
(defun HASH-TABLE-TEST (x)
(si:function-name (cli::test-function x)))

(defun PSEUDO-QUOTE-READER (stream subchar arg)
  "Reader to convert a function spec into a more parsable format."
  (declare (ignore subchar arg))
  (eval
   (list 'quote
     (second (read-from-string
          (nsubstitute #\space #\#
       (concatenate 'string "("
        (read-line stream t nil t) ")")
                   :test #'equal))))))

(defun MAKE-KEYWORD (x)
"Makes a keyword out of a symbol."
 (if (keywordp x) x (intern (symbol-name x) 'keyword)))

(defun NEWSYM (symbol)
  "Similar to GENSYM, but allows access to the gensym counter unlike pre-ANSI GENSYM."
  (if (null (get symbol 'namecounter))
      (setf (get symbol 'namecounter) 0))
  (read-from-string (concatenate 'string (string symbol)
  (format nil "~S" (incf (get symbol 'namecounter))))))

(defmethod COPY-INSTANCE ((instance T))
  "Provides shallow copying of any instance: returns a new copy of a
given clos instance, writ as a method so youse gys can write ur own."
(let* ((copy (make-instance (instance-name instance)))
       (slots (all-slotnames instance)))
    (dolist (slot slots)
      (if (not (slot-boundp instance slot))
      (slot-makunbound copy slot)
      (setf (slot-value copy slot)(slot-value instance slot))))
    copy))

;;; ---- unbound slot handler ----

(defun UNBOUND-SLOT-TOKEN-P (x)
"Predicate: "
(and (symbolp x)(equal x *unbound-slot-token*)))

#+(or akcl allegro-v4.0)
(defmethod ALL-SLOTS-AND-VALUES ((instance T))
"returns an alist of slot value pairs.
 NOTE: Each alist cell is a LIST, NOT a CONS!
 Also, this has been modified to deal with unbound slots."
(let ((answers nil))
  (dolist (slot (all-slotnames instance) answers)
  (setf answers (nconc answers
    (list slot (if (slot-boundp instance slot)
             (slot-value instance slot)
                 *unbound-slot-token*)))))
  answers))

#-(or akcl allegro-v4.0)
(defmethod ALL-SLOTS-AND-VALUES ((instance T))
"returns an alist of slot value pairs.
 NOTE: Each alist cell is a LIST, NOT a CONS!
 Also, this has been modified to deal with unbound slots."
  (loop for slot in (all-slotnames instance) nconc
    (list slot (if (slot-boundp instance slot)
             (slot-value instance slot)
                 *unbound-slot-token*)) into answers
             finally (return answers)))

(defun PRSLOT (key val &optional (stream *standard-output*))
"Simple function to be used by MAP-INSTANCE, printing out a slots key and value, ala
DESCRIBE."
(format stream "Key: ~a, Value: ~a~%" key val))

#+allegro-v4.0
(defun MAP-INSTANCE (function instance &key (modify T)(concat nil))
"Iterator over the slots in an instance, ala MAPHASH. Takes a function of the
keyword/ value (2 arguments, not ONE!)."
(let* ((slotnames (all-slotnames instance))
       (answers nil)
       (result nil))
(dolist (slot slotnames answers)
    (setf result (funcall function slot (slot-value instance slot)))
    (when concat (setf answers (append answers (list result))))
    (when modify (setf (slot-value instance slot) result)))
        (if (null concat) instance (flatten1 answers))))

#-(or akcl allegro-v4.0)
(defun MAP-INSTANCE (function instance &key (modify T)(concat nil))
"Iterator over the slots in an instance, ala MAPHASH. Takes a function of the
keyword/ value (2 arguments, not ONE!)."
(let* ((init (all-slots-and-values instance))
      (answer (loop with con = nil
      until (null init)
      as key = (pop init)
      as val = (pop init)
      as result = (funcall function key val)
      when concat do (setf con (append con (list result)))
      when modify do (setf (slot-value instance key) result)
      finally (return (if (null concat) instance (flatten1 con))))))
  answer))

(defun CLEAR-GLOBAL-VARS-AND-HTABS ()
"Initializes the SAVE-OBJECT enviroment for recording graph cycles."
     (setf *structs-seen* nil *struct-vars* nil)
     (setf *vectors-seen* nil *vector-vars* nil)
     (setf *arrays-seen* nil *array-vars* nil)
     (setf *htabs-seen* nil *htab-vars* nil)
     (setf *seen* nil *vars* nil)
         (clrhash *save-object-hash-table*))

(defun CLEAR-SAVE-OBJECT ()
"shorthand to clear the environment."
(clear-global-vars-and-htabs)
)

;;; The main routine, SAVE-OBJECT.

(defun SAVE-OBJECT (object-instance filename &key
                    (compile nil)
                    (variable '*db-input*)
                    (if-exists :append)
                    (print-pretty nil)
                    (max-print-level 10000000)
                    (package nil)
                    (if-does-not-exist :create))
         (setf *global-instance-count* 0)
     (setf *global-object-count* 0)
     (clear-global-vars-and-htabs)
(let* ((*print-level*  max-print-level)
       (*print-circle* t)
       #+lispm (scl::*print-structure-contents* t)
       (*print-pretty* print-pretty)
       (*print-length* 50000000)
       (*package*      (or (and package (find-package package))
               *package*))
     (pathname       filename)
     (form           (MAKE-LET-FORM object-instance
                    (get-dump-form object-instance))))
    (setf (get '.%%SL%%. 'namecounter) 0)
(with-open-file (stream pathname :direction :output :if-exists if-exists
            :if-does-not-exist if-does-not-exist)
(format stream ";;;-*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: ~a -*-~%" (package-name *package*))
     (format stream "~%~s"
         `(in-package ',(read-from-string (package-name *package*))))
     (write-global-header stream
              '.%%SL%%. 0
              *global-instance-count*)
     (format stream "~%~s" `(setq ,variable ,form)))
    (format t "~& object saved to file: ~A" pathname)
    (when compile (format t "~% compiling file ~A" pathname)
              (compile-file pathname)
          (format t "~% done compiling file ~A" pathname))))

;;;================================
;;; ======= dump forms. ===========
;;;================================

(defun STREAM-DUMP-FORM (instance)
"Very machine dependent! for now, just recognize we got one, return NIL as DUMP FORM."
(format t "Recognized a stream in save object: ~a.~%" instance)
NIL)

(defun STRUCTURED-OBJECT-DUMP-FORM (object)
"Routine which deals with any potentially circular objects (PCOS)."
(cond ((null object) NIL)
      ((%classp object)(class-dump-form object))
       ((instance-p object)
     (if (member object *seen* :test #'equal)
         (symbol-dump-form
          (nth (position object *seen* :test #'equal) *vars*))
       (progn (push object *seen*)
          (setq *vars* (pushsym *vars*))
          (instance-dump-form object))))
      ((structure-p object)
       (if (member object *structs-seen* :test #'equal)
            (symbol-dump-form (nth (position object *structs-seen*
                            :test #'equal)
                      *struct-vars*))
           (progn (push object *structs-seen*)
          (setf *struct-vars* (pushsym *struct-vars*))
          (structure-dump-form object))))
#|
      ((vectorp object)
       (if (member object *vectors-seen* :test #'equal)
            (progn (symbol-dump-form (nth (position object *vectors-seen*
                            :test #'equal)
                      *vector-vars*)))
       (progn (push object *vectors-seen*)
          (setf *vector-vars* (pushsym *vector-vars*))
          (vector-dump-form object))))
      ((arrayp object)
       (if (member object *arrays-seen* :test #'equal)
            (progn (symbol-dump-form (nth (position object *arrays-seen* :test #'equal)
                  *array-vars*)))
       (progn (push object *arrays-seen*)
          (setf *array-vars* (pushsym *array-vars*))
          (array-dump-form object))))
|#
      ((hash-table-p object)
       (if (member object *htabs-seen* :test #'equal)
       (symbol-dump-form  (nth (position object *htabs-seen* :test #'equal) *htab-vars*))
       (progn (push object *htabs-seen*)
                  (setf *htab-vars* (pushsym *htab-vars*))
                  (setf *current-htab-size* (or (hash-table-size object) 5000))
                  (setf *current-htab-rehash-threshold* (or (hash-table-rehash-threshold object) 20))
                  (setf *current-htab-test* (hash-table-test object))
                  (setf *current-htab-rehash-size* (or (hash-table-rehash-size object) 67))
          (htab-dump-form object))))
      ((circular-list-p object)(circular-list-dump-form object))
      (T (error "couldnt parse ~a as a structured object!" object))))

(defun %LOAD-HTAB  (htab &optional lst)
""
(loop
(when *debug-htab-load* (format t "setting slot ~a to ~a.~%"
      (first lst)(second lst)))
      (setf (gethash (pop lst) htab)(pop lst))
    (when (null lst)(return htab))))

;;; Map lucid/allegro htab incompatibility of rehash threshold
;;; parameter into mutually acceptable values. (i.e. fix bug)

#+lucid
(defun SCALE-REHASH-THRESHOLD (num)
(if (> num 1)(float (/ num 100)) num))

#+allegro
(defun  SCALE-REHASH-THRESHOLD (num)
(if (<= num 1)(* num 100) num))

#-(or allegro lucid)
(defun SCALE-REHASH-THRESHOLD (num)
num)

(defun MAKEHASH (h &key (test #'eql)
                    (size 5000)
                (rehash-size 67)
                (rehash-threshold 0.65)
                values)
""
(let ((htab (or h (make-hash-table :test test
                   :size size
                   :rehash-size rehash-size
 :rehash-threshold (scale-rehash-threshold rehash-threshold)))))
(if (null values) htab
  (progn (%load-htab htab values) htab))))

(defun HTAB-DUMP-FORM (htab)
"Dump for for hash tables.... "
`(makehash ,(get-instance-label htab)
       :test ,(get-dump-form (hash-table-test htab))
        :size ,(get-dump-form (hash-table-size htab))
        :rehash-size ,(get-dump-form (hash-table-rehash-size htab))
        :rehash-threshold ,(get-dump-form
            (hash-table-rehash-threshold htab))
        :values (LIST ,@(get-htab-values htab))))

(defun GET-HTAB-VALUES (htab)
(let ((values nil))
(maphash #'(lambda (key val)
         (push (get-dump-form val) values)
         (push (get-dump-form key) values))
htab) values))

(defun PRINT-HTAB (htab)
(maphash #'(lambda (key val)
(format t "~%Key: ~a, value=~a.~%" key val))
htab))

(defun SIMPLE-ARRAY-DUMP-FORM (array)
"Numerical arrays are stored using this routine...."
`(make-array ,(get-dump-form (array-dimensions array))
         :element-type ',(array-element-type array)
         :initial-contents ,(list-array array)))

(defun PACKAGE-DUMP-FORM (package)
"assume its there in the environment, somewhere."
(let ((pn (get-dump-form (package-name package))))
`(FIND-PACKAGE ,pn)))

(defun STREAM-P (x)
"Avoids problems with vendor-made type confusion."
(and (not (%classp x))(streamp x)))

;;; the workhorse. NOTE: The case statement is very ORDER-DEPENDENT!
;;; If your version of CLOS supports specialization on ALL LISP types,
;;; you could write this as a set of DUMP-FORM methods on the LISP types.
;;; This has not always been possible with PCL, thus the case statement.
;;; NOTE that a CONS is not necessarily a list! CONS-P distinguishes
;;; between items such as (CONS 'A 'B) and (LIST 'A 'B).
;;;
;;; Notice that this version uses SAFE-CLASS-DUMP-FORM to prevent class
;;; definition overwrite. Use CLASS-DUMP-FORM below if you do not want this
;;; behavior!

(defun INSURE-LIST (X)
(if (listp x) x (list x)))

(defun REPEATING-ELEMENT-LIST-P (instance)
(if (< (length instance) *make-list-length-threshold*) nil
(let ((test (first instance)))
  (every #'(lambda (e)(equal e test)) instance))))

(defun REPEATING-ELEMENT-LIST-DUMP-FORM (instance)
(let ((length (length instance))
      (form (get-dump-form (first instance))))
  `(MAKE-LIST ,length :initial-element ,form)))

(defun REC-LIST-DUMP-FORM (l)
`(LIST ,@(%rec-list-dump-form l)))

(defun %REC-LIST-DUMP-FORM (l)
""
(cond ((null l) nil)
      ((not (listp (first l)))
       (cons (get-dump-form (first l))
         (%rec-list-dump-form (rest l))))
      (T (cons (%rec-list-dump-form (first l))
           (%rec-list-dump-form (rest l))))))

(defun GET-DUMP-FORM (instance)
"New incarnation of get-dump-form: if the instance is a structured
object, construct a representation for it anticipating that it might
be a PCO. NOTE: in MCL Common Lisp, note that STREAMS are implemented as
CLASSES! This makes it possible to SAVE-OBJECT things like *TERMINAL-IO*!"
    (cond ((null instance) nil)
      ((equal instance T) T)
      ((circular-cons-p instance)(circular-cons-dump-form instance))
      ((numberp instance) instance)
      ((or (pathnamep instance)
           (stringp instance)
               (keywordp instance)
               (special-marker-p instance)
           (characterp instance)) instance)
          ((packagep instance)(package-dump-form instance))
      ((quoted-symbol-p instance)(quoted-symbol-dump-form instance))
      ((symbolp instance)(symbol-dump-form instance))
      ((and (arrayp instance)(not (pco-p instance)))
                (simple-array-dump-form instance))
      ((vectorp instance)(vector-dump-form instance))
          ((cons-p instance)(cons-dump-form instance))
      ((pco-p instance)(structured-object-dump-form instance))
      ((arrayp instance)(array-dump-form instance))
      ((functionp instance)(compiled-function-dump-form instance))
          ((stream-p instance)(stream-dump-form instance))
          ((readtablep instance)(readtable-dump-form instance))
      ((repeating-element-list-p instance)
       (repeating-element-list-dump-form instance))
((simple-lex-list-p instance)(simple-list-dump-form instance))
((simple-quoted-list-p instance)(simple-quoted-list-dump-form instance))
((quoted-list-p instance)(quoted-list-dump-form instance))
((simple-list-p instance)(simple-list-dump-form instance))
;;;((LISTP instance)(rec-list-dump-form instance))
((listp instance)     `(LIST ,@(mapcar #'(lambda (thing)
              (get-dump-form thing)) instance)))
      (T (error "could not parse object ~a, of type ~a.~%"
            instance (type-of instance)))))

(defun STRIP-PACKAGE (x)
"strip the package designator off the symbol, return the rest,
if keyword, return self.."
(if (keywordp x) x
  (intern (symbol-name x))))

(defun SLOT-EXISTS-P-ANY (instance name)
"returns t if the slotname exists with any package designator."
(let ((slots (mapcar #'strip-package (all-slotnames instance))))
  (member (strip-package name) slots :test #'equal)))

(defun QUOTED-SYMBOL-P (X)
"Predicate: returns t if the object is a quoted symbol."
(and (listp x)(equal (first x) 'quote)(symbolp (second x))))

(defun FLATTEN1 (cells)
(let ((answer nil))
(dolist (cell cells answer)
(setf answer (nconc answer cell)))
answer))

(defun UNSAVEABLE-SLOT-TOKEN-P (X)
"Predicate"
(equal x *unsaveable-slot-token*))

(defun GET-SLOT-VALUES (clos-instance)
  "given a pcl/clos instance,constructs a plist of all the saveable
   slot/value pairs."
  (incf *global-instance-count*)
  (let ((unsaveable (get-unsaveable-slotnames clos-instance)))
(map-instance #'(lambda (key val)
  (if (or (member key unsaveable :test #'equal)
          (member key *global-unsaveable-slotnames* :test #'equal))
                  (list (make-keyword key) *unsaveable-slot-token*)
          (list (make-keyword key)(get-dump-form val))))
          clos-instance
          :modify nil
          :concat t)))

(defun %%GET-DEFSTRUCT-VALUES (clos-instance)
  "given a pcl/clos instance,constructs a plist of all the saveable
   slot/value pairs."
  (incf *global-instance-count*)
(mapcan #'cdr
(mapstruct #'(lambda (key val)
          (list (make-keyword key)(get-dump-form val)))
          clos-instance
          :modify nil
          :concat t)))

(defun MAKEVAR (&optional (label '.%%SL%%.))
"makes a new variable for something in the global object hashtable."
(incf *global-object-count*)
(newsym label))

(defun PUSHSYM (list &optional (label '.%%SL%%.))
"label must match with special-marker-p, and must be upper-case."
  (push (newsym label) list))

(defun MAKESYMS (symbol min max &optional (pkg *package*))
(let ((c min))
 (progn
   #+excl (setf excl::*nowarn* T)
#+symbolics (setf compiler::*suppress-compiler-warnings* T)
(dotimes (count max)
 (incf c)

 (eval `(defvar
,(read-from-string (concatenate 'string (format nil "~A" symbol)
                (format nil "~A" c))
  pkg))))
#+excl (setf excl::*nowarn* NIL)
#+symbolics (setf compiler::*suppress-compiler-warnings* NIL)
)))

(defun WRITE-GLOBAL-HEADER (stream symbol min max
                  &optional (pkg-name (package-name *package*)))
(format stream (format nil "~%(EVAL-WHEN (COMPILE LOAD EVAL)
                       (DATABASE:MAKESYMS '~A ~A ~A ~s))~%"
               symbol min max pkg-name)))

(defun NASSOC (key list &key (test #'equal))
"Given a key and a list, return the thing AFTER that key in the list.
 Similar to GETF."
  (let ((where (position key list :test test)))
    (when where (nth (1+ where) list))))

(defun %CONS-P (X)
"Internal dotted list predicate..."
(and (not (null (list-length x)))
     (listp x)
     (atom (cdr (last x)))
     (not (null (cdr (last x))))))

(defun CONS-P (x)
  "ingenious predicate for testing whether something is a cons cell vs. a list.
   note that this returns nil for (LIST 'A 'B) whereas it returns T for (CONS 'A 'B)."
(cond ((not (listp x)) NIL)
((and (listp x)(null (list-length x))) nil)
((or (%cons-p x)(and (listp x)(null (listp (rest x))))) T)
(T NIL)))

(defun CONS-DUMP-FORM (item)
  `(CONS ,(get-dump-form (first item))
     ,(get-dump-form (rest item))))

(defun %INSURE-LIST (X)
(if (listp x) x
    (list nil x)))

(defun LIST-ARRAY (array)
""
  (list-array-aux array 0 nil))

#-(or akcl allegro-v4.0)
(defun LIST-ARRAY-AUX (array level subscript-list)
""
  (let ((new-level (1+ level))
    (dims (array-dimensions array)))
    (loop for i from 0 to (1- (nth level dims))
      collect
      (cond ((equal level (1- (length dims)))
         (let* ((aref-arg-list
             (cons array (append subscript-list
                         (list i))))
            (array-val (apply #'aref aref-arg-list)))
           (if (numberp array-val) array-val
             (get-dump-form array-val))))
        (T (list-array-aux array new-level
                   (append subscript-list (list i)))))
      into temp finally (return (append '(list) temp)))))

#+(or akcl allegro-v4.0)
(defun LIST-ARRAY-AUX (array level subscript-list)
""
  (let ((new-level (1+ level))
    (dims (array-dimensions array))
    (answers nil))
    (dotimes (i (1- (nth level dims)) answers)
      (setf answers (append answers (list
      (cond ((equal level (1- (length dims)))
         (let* ((aref-arg-list
             (cons array (append subscript-list
                         (list i))))
            (array-val (apply #'aref aref-arg-list)))
           (if (numberp array-val) array-val
             (get-dump-form array-val))))
        (T (list-array-aux array new-level
           (append subscript-list (list i)))))))))
 (append '(list) answers)))

#-(or akcl allegro-v4.0)
(defun COERCE-2D-ARRAY (2d-array)
  (let ((rows (array-dimension 2d-array 0))
    (cols (array-dimension 2d-array 1)))
    (loop for x from 0 to (1- rows) collect
      (loop for y from 0 to (1- cols) collect
        (aref 2d-array x y)) into answers
      finally (return answers))))

#+(or akcl allegro-v4.0)
(defun COERCE-2D-ARRAY (2d-array)
  (let ((rows (array-dimension 2d-array 0))
    (cols (array-dimension 2d-array 1))
    (answers nil)
    (temp nil))
    (dotimes (x (1- rows) answers)
(setf temp nil)
(setf answers (append answers (list
       (dotimes (y (1- cols) temp)
    (setf temp (append temp (list (aref 2d-array x y)))))))))
answers))

(defun ARRAY-DUMP-FORM (array)
  "this function return a make-array form."
  (setf *print-array* T)
   (let ((vals (list-array array)))
  `(let ((tmp (allocate-array ,(get-dump-form (array-dimensions array))
           :element-type ',(array-element-type array)
           :adjustable ,(adjustable-array-p array)
           :initial-contents ,(get-dump-form vals))))
     TMP)))

(defun VECTOR-DUMP-FORM (array)
  "this function return a make-array form."
  (setf *print-array* T)
   (let ((vals (list-array array)))
  `(let ((tmp (allocate-array ,(get-dump-form (array-dimensions array))
           :element-type ',(array-element-type array)
           :adjustable ,(adjustable-array-p array)
           :initial-contents ,(get-dump-form vals))))
     TMP)))

;;; HASH TABLES...

(defun CREATE-HASH-TABLE (&key (test #'eql)
                   (size 67)
                   (rehash-size nil)
                   (rehash-threshold nil))
(let ((args (remove nil `(:size ,(get-dump-form size)
     :test ,test
        ,@(when rehash-size (list :rehash-size (get-dump-form rehash-size)))
        ,@(when rehash-threshold
            (list :rehash-threshold (get-dump-form rehash-threshold)))))))
      (cache-object (apply #'make-hash-table args) :mode :load)))

(defun MAKE-SYM (x)
(if (keywordp x)
    (read-from-string (subseq (symbol-name x) 0))
  x))

(defun GET-EVENS (l)
(let ((answers nil))
(dotimes (count (1- (length l)) answers)
(if (evenp count)(push (nth count l) answers)))
(nreverse answers)))

(defun GET-ODDS (l)
(let ((answers nil))
(dotimes (count (1- (length l)) answers)
(if (oddp count)(push (nth count l) answers)))
(nreverse answers)))

(defun LOAD-HTAB (values &key (test #'eql)
             (size 67)
             (rehash-size nil)
             (rehash-threshold nil))
""
(let ((htab (create-hash-table :test test
                   :size size
                   :rehash-size rehash-size
                   :rehash-threshold rehash-threshold))
(key nil)(val nil))
(dolist (cell values)
    (setf key (first cell))
    (setf val (eval (second cell)))
        (setf (gethash key htab) val))))

;;;; Arrays & Vectors.

(defun ALLOCATE-ARRAY (dims &key (element-type t)
                 (adjustable nil)
                 (initial-contents nil))
"Function to allocate an array. No fill-pointer.
 suggested by [e-mail]."
(make-array dims :element-type element-type
             :initial-contents initial-contents
         :adjustable adjustable))


(defun ALLOCATE-VECTOR (dims &key (element-type t)
                 (adjustable nil)
                 (fill-pointer nil))
"Function to allocate an array. suggested by [e-mail]."
(make-array dims :element-type element-type
          :adjustable adjustable
          :fill-pointer fill-pointer))

;;; Compiled functions.

#+(or :mcl excl)
(defun GET-COMPILED-FUNCTION-NAME (compiled-function)
""
(let ((ans nil)
      (strname ""))
(setq *readtable* (copy-readtable))
(set-dispatch-macro-character #\# #\' (function pseudo-quote-reader))
(set-dispatch-macro-character #\# #\< (function pseudo-quote-reader))
(setf strname (format nil "~S" compiled-function))
(setq ans (read-from-string (SUBSEQ strname 0 (length strname))))
(setq *readtable* (copy-readtable nil))
ans))

;;; Massive kludge for encountering READTABLES!!!

(defun READTABLE-DUMP-FORM (i)
"Doesnt seem to be a good way to probe the internals of readtables, even
machine specific ways!!!!"
(declare (ignore i))
`(copy-readtable *readtable*))

;;; Massive kludge for pre-ansi hash table specs!!!!

#+lispm
(defun PARSE-HASH-TABLE-SPEC (htab)
(let ((ans nil))
(setq *readtable* (copy-readtable))
(set-dispatch-macro-character #\# #\' (function pseudo-quote-reader))
(set-dispatch-macro-character #\# #\< (function pseudo-quote-reader))
(setq ans (rest (butlast (read-from-string
               (concatenate 'string "(" (subseq (format nil "~a" htab) 8) ")")))))
(setq *readtable* (copy-readtable nil))
ans))



#+allegro-v4.0
(eval-when (load eval compile)

(defun HASH-TABLE-TEST (htab)
#'eql)

(defun HASH-TABLE-SIZE (htab)
32)

(defun PARSE-HASH-TABLE-SPEC (htab)
(let ((ans nil))
(setq *readtable* (copy-readtable))
(set-dispatch-macro-character #\# #\' (function pseudo-quote-reader))
(set-dispatch-macro-character #\# #\< (function pseudo-quote-reader))
(setq ans (rest (butlast (read-from-string
(concatenate 'string "(" (subseq (format nil "~a" htab) 8) ")")))))
(setq *readtable* (copy-readtable nil))
ans))
) ;;; end of allegro ver 4.0 eval-when....

#+rel8
(defun HASH-TABLE-REHASH-SIZE (x)
""
(future-common-lisp:hash-table-rehash-size x))

#+rel8
(defun HASH-TABLE-REHASH-THRESHOLD (x)
""
(future-common-lisp:hash-table-rehash-threshold x))

#+rel-7-2
(defun HASH-TABLE-REHASH-SIZE (x)
""
(let ((spec (parse-hash-table-spec x)))
  (getf spec :rehash-size 32)))

#+rel-7-2
(defun HASH-TABLE-REHASH-THRESHOLD (x)
""
(let ((spec (parse-hash-table-spec x)))
  (getf spec :rehash-threshold 0.5)))

;;; Functions and Generic Functions.

#+:mcl
(eval-when (load eval compile)

(defun GENERIC-FUNCTION-NAME (instance)
(get-compiled-function-name instance))

(defun GENERIC-FUNCTION-LAMBDA-LIST (gf)
""
(function-lambda-expression gf))

(defun %GENERIC-FUNCTION-P (X)
""
(ccl::standard-generic-function-p x))

(defun COMPILED-FUNCTION-DUMP-FORM (X)
"dump form for hashmark-quote e.g. (FUNCTION name) forms."
  `(function ,(get-compiled-function-name x)))

(defun METHOD-SPECIALIZERS (method)
""
(ccl:specializer-direct-generic-functions method))

(defun METHOD-GENERIC-FUNCTION (gf)
""
(ccl:method-generic-function gf))

) ;;; end of MCL function & generic function eval-when!

(defun GENERIC-FUNCTION-DUMP-FORM (instance)
"Dump Form for saving out generic functions..."
     (let ((name (generic-function-name instance))
       (arglist (generic-function-lambda-list instance))
       (documentation (%generic-function-documentation instance)))
       `(OR (FIND-GENERIC-FUNCTION ',name)
        (DEFGENERIC ,name ,arglist (:DOCUMENTATION ,(or documentation ""))))))

(defun METHOD-DUMP-FORM (instance)
"dump form for saving out method objects."
     (LET* ((name (generic-function-name (method-generic-function instance)))
        (qualifiers (method-qualifiers instance))
        (specializers (method-specializers instance)))
       `(FIND-METHOD (FUNCTION ,name)
             (LIST ,@qualifiers)
             (LIST ,@(DO-SPECIALIZERS specializers))
             NIL)))

#+excl
(defun COMPILED-FUNCTION-DUMP-FORM (X)
"dump form for hashmark-quote e.g. (FUNCTION name) forms."
  `(function ,(get-compiled-function-name x)))

#+lispm
(defun COMPILED-FUNCTION-DUMP-FORM (X)
"dump form for hashmark-quote e.g. (FUNCTION name) forms."
  (if (si:lexical-closure-p x) nil
  `(FUNCTION ,(si:compiled-function-name x))))

;;;; PCL/CLOS classes and instances.
;;;; NOTE: CLASS DEFINITIONS, WHEN READ IN, WILL OVERWRITE THE
;;;; CLASS DEFINITION PREVIOUSLY IN MEMORY. IF YOU DO NOT WANT THIS
;;;; TO HAPPEN, REPLACE 'DEFCLASS' BELOW WITH 'FIND CLASS' + the
;;;; APPROPRIATE ARGUMENTS!

(defun SAFE-CLASS-DUMP-FORM (instance)
"This version of the class-dump-form function WILL NOT overwrite
 current class definitions with the same name. It is the one invoked
 by GET-DUMP-FORM and SAVE-OBJECT."
  (let* ((name (%class-name instance))
       (supertypes (get-class-superclasses instance))
       (slots (generate-class-slot-forms instance))
       (options (generate-class-options-form instance)))
`(OR (FIND-CLASS ',name)
     (DEFCLASS ,name ,supertypes ,slots ,@options))))

(defun CLASS-DUMP-FORM (instance)
"This version of the class-dump-form function WILL OVERWRITE
 CURRENT CLASS DEFINITIONS WITH THE SAME NAME. Sunstitute a call to
 this one in GET-DUMP-FORM and SAVE-OBJECT."
 (let* ((name (%class-name instance))
       (supertypes (get-class-superclasses instance))
       (slots (generate-class-slot-forms instance))
       (options (generate-class-options-form instance)))
   (if (builtin-class-p instance) `(FIND-CLASS ',name)
     `(DEFCLASS ,name ,supertypes ,slots ,@options))))

(defun SYM< (a b)
"Predicate to see if symbol a is alphabetically before symbol b. T if a is."
(string< (format nil "~A" A)(format nil "~A" b)))

(defun SYMF< (a b)
"Predicate to see if symbol a is alphabetically before symbol b. T if a is."
(string< (format nil "~A" (FIRST A))(format nil "~A" (first b))))

(defun GET-ORDERED-SLOT-NAMES (I)
"Returns a list of the slot names of the instance, alphabetized."
(cond ((instance-p i)(sort (all-slotnames i) #'sym<))
      ((structure-p i)#-excl (get-defstruct-slotnames i)
                      #+excl (%get-defstruct-slotnames i)
              )
      (T (error "couldnt parse object ~a!" i))))

(defun FLATTEN (l)
""
(let ((answers nil))
(dolist (cell l answers)
    (setf answers (nconc answers cell)))
answers))

(defun PAIR-UP (l)
""
(let ((answers nil))
(loop (push (list (pop l)(pop l)) answers)
      (when (null l)(return (reverse answers))))))

(defun ALPHABETIZE-BY-KEYWORD (lst)
""
(let ((alpha-cells (sort (pair-up lst) #'symf<)))
  (mapcar #'second alpha-cells)))

(defun GET-ORDERED-SLOT-VALUES (i)
"Gets the dump forms out of the instance slot values, then alphabetizes them."
 (cond ((instance-p i)(alphabetize-by-keyword (get-slot-values i)))
       ((structure-p i)(%%get-defstruct-values i))
       (T (error "could not parse object ~a~%" i))))

(defun %FILL-INSTANCE (i ordered-slot-values)
"Fills in the slots alphabetically.
Assumes the slot values come into the function
 alphabetically ordered already: Returns the instance object.
NOTE: modification to deal with unbound slots is included!"
(if (null ordered-slot-values) i
  (let ((osv (copy-list ordered-slot-values))
    (unbound-slot nil)
    (default-slot nil)
    (names (get-ordered-slot-names i))
    (thang nil)
    (name nil))
(loop (setf name (pop names))
      (setf thang (pop osv))
      (cond ((unbound-slot-token-p thang)
         (setf unbound-slot T)
         (setf default-slot NIL))
        ((unsaveable-slot-token-p thang)
             (setf default-slot T))
         ((and thang (symbolp thang))
          (setf thang `(quote ,thang))
          (setf unbound-slot NIL)
          (setf default-slot NIL))
        (T (setf unbound-slot NIL)
           (setf default-slot NIL)))
          ;;; if this slot was marked as unsaveable,
      ;;; let the value be whatever allocate-instace willed it to be.
      ;;; if it was unbound when saved, make the new instace slot
      ;;; unbound, too. if neither, put the supplied slot value from
          ;;; the file in the slot.
      (if default-slot NIL ;;; do nothing.
      (if (not unbound-slot)
      (cond ((instance-p i)
      (setf (slot-value i name) thang)) ;;; put the value in.
      ((structure-p i)(set-defstruct-value i name thang)))
      (slot-makunbound i name))) ;;; make the slot unbound.
      (when (and (null names)(null osv))(return i))))))

#+pcl
(defmethod %ALLOCATE-INSTANCE (class-object)
(pcl::allocate-instance class-object))

#+allegro-v4.0
(eval-when (load eval compile)

(defmethod CLOS::ALLOCATE-INSTANCE ((self clos:structure-class) &rest initargs)
(declare (ignore initargs))
(allocate-struct (instance-name self)))

(defmethod %%ALLOCATE-INSTANCE ((self clos:structure-class))
(allocate-struct (instance-name self)))

(defmethod %%ALLOCATE-INSTANCE ((self symbol))
(if (get-symbol-defstruct-spec self)
    (allocate-struct self)))

(defmethod CLOS::ALLOCATE-INSTANCE ((self symbol) &rest init-plist)
    (allocate-struct self))

(defmethod GET-SYMBOL-DEFSTRUCT-SPEC (self)
(typep (find-class self nil) 'clos:structure-class))

) ;;; end of allegro ver4.0 eval-when...

#+:mcl
(defun %STRUCTURE-P (X)
"predicate, if symbol returns t if it names a struct."
(and (symbolp x)
     (equal (class-name (class-of (find-class x nil)))
        'STRUCTURE-CLASS)))

(defun ALLOCATE-HTAB (htab &rest arglist)
"Allocates the empty husk of a hash table,
 getting its attributes from the object itself."
(declare (ignore htab))
(let ((size (getf arglist :size))
      (rehash-size (getf arglist :rehash-size))
                   (test (getf arglist :test))
                   (rehash-threshold (getf arglist :rehash-threshold)))
(make-hash-table :size size
                 :rehash-size rehash-size
                 :rehash-threshold
         (scale-rehash-threshold rehash-threshold)
                 :test test)))

#+clos
(defun %ALLOCATE-INSTANCE (class-object &rest htab-plist)
  (cond ((equal class-object 'HASH-TABLE)
     (allocate-htab class-object
            :size (getf htab-plist :size
                    5000)
            :rehash-size (getf htab-plist :rehash-size 67)
:rehash-threshold (getf htab-plist :rehash-threshold 0.67)
            :test (getf htab-plist :test #'eql)))
        ((%structure-p class-object)
     #-excl (clos::allocate-instance class-object)
     #+allegro-v4.0(%%allocate-instance class-object)
     #+allegro-v4.1(clos::allocate-instance class-object)
     )
        (T (when *debug-instance-storage*
 (format t "now trying to allocate an instance for ~a!" class-object))
           (when (symbolp class-object)
         (setf class-object (find-class class-object nil)))
           (when class-object (clos::allocate-instance class-object)))))

#+clos
(defun FILL-INSTANCE (new vals)
"New: allocates an instance given classname, the vals are the alphabetized list of
 slot values extracted from the target instance. returns the newly filled in instance."
  (%fill-instance new vals)
  new)

#+pcl
(defun FILL-INSTANCE (classname vals)
"New: allocates an instance given classname, the vals are the alphabetized list of
 slot values extracted from the target instance. returns the newly filled in instance."
(let* ((new (pcl::allocate-instance (find-class classname))))
  (%fill-instance new vals)
  new))

;;; ========= user defined dump forms ==========

(defun INSTANCE-DUMP-FORM (instance)
"NEW VERSION. ATTEMPTS TO DEAL WITH SIRCULAR SLOT VALUE REFS,
Basic dump form for clos/pcl instances. checks if the instance has a custom
 dump form, binds it to a generated symbol name, recursively expands the
 instances contents."
(declare (special tmp))
  (if (has-dump-form-p (instance-name instance))
      `(setq ,(get-instance-label instance) ,(funcall #'(lambda (x)
                       (get-dump-form x))
                       instance))
 `(fill-instance ,(get-instance-label instance)
         (LIST ,@(get-ordered-slot-values instance)))))

;;; symbols.

(defun SPECIAL-MARKER-P (X &optional (label ".%%SL%%."))

"label must match with pushsym, and must be upper-case."
  (search label (format nil "~A"  x) :test #'equal))

(defun SYMBOL-DUMP-FORM (instance)
"Better bolder symbol saving formula which includes the package data implicitly."
(if (null instance) NIL
(if (special-marker-p instance) instance
(read-from-string (format nil "~a" (concatenate 'string "'"
                 (package-name (symbol-package instance)) "::"
                          (symbol-name instance)))))))

(defun SIMPLE-QUOTED-LIST-P (X)
"Predicate, if somethings a quoted list...."
(and (not (cons-p x))
     (listp x)
     (not (circular-list-p x))
     (not (every #'null x))
     (every #'(lambda (sub)(and (not (special-marker-p sub))
                (or (numberp sub)
                   (characterp sub)
                   (stringp sub)
                   (symbolp sub))))

        x)))


(defun QUOTED-LIST-P (x)
"Predicate, if somethings a quoted list...."
(and (not (cons-p x))
     (listp x)
     (not (circular-list-p x))
     (not (every #'null x))
     (every #'(lambda (sub)(or (numberp sub)
                   (characterp sub)
                   (stringp sub)
                   (AND (symbolp sub)
                   (not (special-marker-p sub)))
                   (quoted-list-p sub)))
        x)))

(defun SIMPLE-QUOTED-LIST-DUMP-FORM (x)
(let ((it (quoteit x)))
`(QUOTE (,@it))))

(defun QUOTEIT (l)
(cond ((null l) nil)
      ((null (first l))
       (cons nil (quoteit (rest l))))
      ((equal (first l) T)
       (cons t (quoteit (rest l))))
      ((not (listp (first l)))
       (cons (get-dump-form (first l))(quoteit (rest l))))
      ((simple-quoted-list-p (first l))
       (cons (simple-quoted-list-dump-form (first l))
         (quoteit (rest l))))
      (T (cons (quoted-list-dump-form (first l))
           (quoteit (rest l))))))

#|
(defun QUOTED-LIST-P (x)
"Predicate, if somethings a quoted list...."
(and (not (cons-p x))
     (listp x)
     (not (circular-list-p x))
     (not (every #'null x))
     (every #'symbolp x)))
|#

(defun QUOTED-LIST-DUMP-FORM (instance)
"If something is a quoted list, put the quote at the right place."
(let ((it (quoteit instance)))
`(QUOTE ,instance)))

;;;; ===================================== TESTS ============================================

;;; *** NASTY TEST SUITE: A collection of self-referencing consolas that put this code to the test!

(setf *print-circle* t)

(setq l '(a b c d e f))

(setf (third l) (cdr l))

(defstruct (boo (:type list))  x y)

(setq b (make-boo
      :x (vector 1 2 (make-hash-table) 4)
      :y (make-boo :x '(#\a #c(1.7 4.99)))))

(defstruct boo1  x y)

(setq b1 (make-boo1
      :x (vector 1 2 (make-hash-table) 4)
      :y (make-boo :x '(#\a #c(1.7 4.99)))))

#+lispm
(defvar *nasty-path* "e:>kerry>")

#+:mcl
(defvar *nasty-path* "Macintosh HD:")

#+:mcl
(setf *nasty-path* "Macintosh HD:")

;;; UNIX BOX PATH:

#+(or excl akcl lucid)
(defvar *nasty-path* "/users/kerry/save-object/tests/")

;;; Test Classes:

(defclass SLOTLESS ()
  ((a)(B)(c)(d)(e)))

(defvar *test-cons-save* (cons 10 (cons (make-hash-table :test #'equal)
                    (make-array 20))))

(defun TEST-CONS-SAVE ()
""
(save-object *test-cons-save* "cons-save-test.lisp"))

(defun TEST-UNBOUND-SLOT-SAVE ()
""
(let ((inst (make-instance 'slotless)))
(save-object inst "slotless-test-save.lisp")))

(defun NASTY-PATH (filename)
""
(concatenate 'string *nasty-path* filename))

(defun LESS-NASTY-INSTANCE-TEST ()
"One instance with one self-reference."
(let ((a (make-instance 'test)))
  (setf (slot-value a 'a) a)
  (setf (slot-value a 'b) a)
  (save-object a (NASTY-PATH "little-instance.lisp"))))

(defvar *a)
(defvar *b)
(defvar *c)
(defvar *d)
(defvar *the-nasties* nil "stored here for later review.")

(defclass BOGON ()
((name :initarg :name
       :accessor bogon-name
       :documentation ""))
(:default-initargs :name "")
(:documentation ""))

(defmethod INITIALIZE-INSTANCE :AFTER ((self bogon) &rest plist)
(declare (ignore plist))
(push self *the-nasties*))

#-lispm
(defmethod PRINT-OBJECT ((self bogon) stream)
(with-slots (name) self
(format stream "#<Test Instance ~A>" name)))

#+lispm
(defmethod PRINT-OBJECT ((self bogon) stream)
(with-slots (name) self
(format stream "#<~A: ~A>" name (si:%pointer self))))

(defclass TEST (bogon)
((a :initarg :a)
 (b :initarg :b)
 (c :initarg :c)
 (name :initarg :name))
(:default-initargs :a nil
           :b nil
           :c nil
           :name "")
(:documentation "Simple test class for the examples below."))

(defstruct foo a b c)

(defun NASTY-STRUCT-TEST ()
(let ((a (make-foo)))
(setf (foo-a a) a)
(save-object a (NASTY-PATH "nnn.lisp"))))

(defun GET-NASTY (filename)
(concatenate 'string *nasty-path* filename ".lisp"))

#+lispm
(defun NASTY-ARRAY-TEST ()
""
(let ((them! nil))
(tv:noting-progress ("Nasty Array Allocation!")
 (setf them! (LIST (make-array '(50 20 36) :element-type 'float
             :initial-element PI)
           (make-array 10 :initial-contents (make-list 10
                               :initial-element "STRINGS!"))
           (make-array '(21 16 33 4) :element-type '(unsigned-byte 32)
                   :initial-element 1024)
           (make-array '(20 20) :element-type 'character
                   :initial-element #\!)))
)
(tv:noting-progress ("Nasty Array Storage!")
(save-object them! (NASTY-PATH "horrid-arrays.lisp")))))

#-lispm
(defun NASTY-ARRAY-TEST ()
""
(let ((them! (LIST (make-array '(50 20 36) :element-type 'float
             :initial-element pi)
           (make-array 10 :initial-contents (make-list 10
                           :initial-element "STRINGS!"))
           (make-array '(21 16 33 4) :element-type '(unsigned-byte 32)
                   :initial-element 666)
           (make-array '(20 20) :element-type 'character
                   :initial-element #\!))))
(save-object them! (NASTY-PATH "horrid-arrays.lisp"))))

(defun NASTY-INSTANCE-TEST ()
  ""
(setf *a (make-instance 'test :name "A")
       *b (make-instance 'test :name "B")
       *c (make-instance 'test :name "C"))
(setf (slot-value *a 'a) *b)
(setf (slot-value *a 'b) *c)
(setf (slot-value *b 'a) *a)
(setf (slot-value *b 'b) *c)
(setf (slot-value *c 'a) *b)
(setf (slot-value *c 'b) *a)
(save-object *a (NASTY-PATH "nasty-inst.lisp")))

(defun BOBS-INSTANCE-TEST ()
  " A ----> B ----> C ----> D
    ^       ^       |       V
    |-------+--------       |
            |----------------   "

(setf *a (make-instance 'test :name "A")
       *b (make-instance 'test :name "B")
       *c (make-instance 'test :name "C")
       *d (make-instance 'test :name "D"))

(setf (slot-value *a 'a) *b)
(setf (slot-value *b 'a) *c)
(setf (slot-value *c 'a) *d)
(setf (slot-value *c 'b) *a)
(setf (slot-value *d 'a) *b)

(save-object *a (NASTY-PATH "bobtest.lisp")))

(defun BOBS-INSTANCE-TEST-2 ()

"BACKPOINTERS ON ALL THE PREVIOUS EXAMPLES
 (two links on each node: twice as many as before, ten.)

    A <---> B <---> C <---> D
    ^       ^       V       V
    V--<>---+-------^       |
            V----<>---------^   "

(setf *a (make-instance 'test :name "A")
       *b (make-instance 'test :name "B")
       *c (make-instance 'test :name "C")
       *d (make-instance 'test :name "D"))

(setf (slot-value *a 'a) *b)
(setf (slot-value *a 'b) *c)

(setf (slot-value *b 'a) *c)
(setf (slot-value *b 'b) *d)
(setf (slot-value *b 'c) *a)

(setf (slot-value *c 'a) *d)
(setf (slot-value *c 'b) *a)
(setf (slot-value *c 'c) *d)

(setf (slot-value *d 'a) *b)
(setf (slot-value *d 'b) *c)
(save-object *a (NASTY-PATH "bobtest2.lisp")))

(defvar *nasty-hash-tables* nil)

(defun NASTY-HASH-CHAIN-TEST ()
" Makes a nested hash table net like this:

     a->b  b->c  c->d  d->e   e->a
    a-----b-----c-----d----->e----->|
    ^                               v
    |<---------------------<---------
      e->a      e->a       e->a   e->"

(setf *nasty-hash-tables* nil)
(let* ((a (make-hash-table))
       (b (make-hash-table))
       (c (make-hash-table))
       (d (make-hash-table))
       (e (make-hash-table)))
(pushnew a *nasty-hash-tables*)
(pushnew b *nasty-hash-tables*)
(pushnew c *nasty-hash-tables*)
(pushnew d *nasty-hash-tables*)
(pushnew e *nasty-hash-tables*)
(setf (gethash 'a->b b) a)
(setf (gethash 'b->a a) b)
(setf (gethash 'b->c c) b)
(setf (gethash 'c->b b) c)
(setf (gethash 'c->d d) c)
(setf (gethash 'd->e e) d)
(setf (gethash 'e->a a) e)
(save-object a (NASTY-PATH "qhash.lisp"))))

(defun NASTIER-STRUCT-TEST ()
(save-object b1 (NASTY-PATH "b1-test.lisp")))

(defun GET-HTAB-KEYS (htab)
(let ((values nil))
(maphash #'(lambda (key val)
         (push key values))
htab)
values))

(defvar *test-struct-form*
'(SETQ *DB-INPUT* (LET* ((.%%SL%%.1 (%ALLOCATE-INSTANCE 'BOO1))) (FILL-STRUCT .%%SL%%.1 '(BOO1)))))

(defvar *test1* (list (make-instance 'test)
              (make-hash-table :test #'eq)
              (list (make-foo)
                (make-foo)
                (list (make-instance 'test)
                  #c(0 1)
                  (make-foo)))))

;;; END OF THE NASTIES.

;;; end of file.